Pattern/expression ambiguity resolution
[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://gitlab.haskell.org/ghc/ghc/wikis/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    MonadP(..),
54    getRealSrcLoc, getPState, withThisPackage,
55    failLocMsgP, srcParseFail,
56    getErrorMessages, getMessages,
57    popContext, pushModuleContext, setLastToken, setSrcLoc,
58    activeContext, nextIsEOF,
59    getLexState, popLexState, pushLexState,
60    ExtBits(..),
61    lexTokenStream,
62    AddAnn,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           unless lambdaCase $ do
1316             pState <- getPState
1317             addError (RealSrcSpan (last_loc pState)) $ text
1318                      "Illegal lambda-case (use LambdaCase)"
1319           return ITlcase
1320         _ -> return ITcase
1321       maybe_layout keyword
1322       return $ L span keyword
1323     Just (keyword, 0) -> do
1324       maybe_layout keyword
1325       return $ L span keyword
1326     Just (keyword, i) -> do
1327       exts <- getExts
1328       if exts .&. i /= 0
1329         then do
1330           maybe_layout keyword
1331           return $ L span keyword
1332         else
1333           return $ L span $ ITvarid fs
1334     Nothing ->
1335       return $ L span $ ITvarid fs
1336   where
1337     !fs = lexemeToFastString buf len
1338
1339 conid :: StringBuffer -> Int -> Token
1340 conid buf len = ITconid $! lexemeToFastString buf len
1341
1342 qvarsym, qconsym :: StringBuffer -> Int -> Token
1343 qvarsym buf len = ITqvarsym $! splitQualName buf len False
1344 qconsym buf len = ITqconsym $! splitQualName buf len False
1345
1346 varsym, consym :: Action
1347 varsym = sym ITvarsym
1348 consym = sym ITconsym
1349
1350 sym :: (FastString -> Token) -> Action
1351 sym con span buf len =
1352   case lookupUFM reservedSymsFM fs of
1353     Just (keyword, NormalSyntax, 0) ->
1354       return $ L span keyword
1355     Just (keyword, NormalSyntax, i) -> do
1356       exts <- getExts
1357       if exts .&. i /= 0
1358         then return $ L span keyword
1359         else return $ L span (con fs)
1360     Just (keyword, UnicodeSyntax, 0) -> do
1361       exts <- getExts
1362       if xtest UnicodeSyntaxBit exts
1363         then return $ L span keyword
1364         else return $ L span (con fs)
1365     Just (keyword, UnicodeSyntax, i) -> do
1366       exts <- getExts
1367       if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts
1368         then return $ L span keyword
1369         else return $ L span (con fs)
1370     Nothing ->
1371       return $ L span $! con fs
1372   where
1373     !fs = lexemeToFastString buf len
1374
1375 -- Variations on the integral numeric literal.
1376 tok_integral :: (SourceText -> Integer -> Token)
1377              -> (Integer -> Integer)
1378              -> Int -> Int
1379              -> (Integer, (Char -> Int))
1380              -> Action
1381 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do
1382   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
1383   let src = lexemeToString buf len
1384   when ((not numericUnderscores) && ('_' `elem` src)) $ do
1385     pState <- getPState
1386     addError (RealSrcSpan (last_loc pState)) $ text
1387              "Use NumericUnderscores to allow underscores in integer literals"
1388   return $ L span $ itint (SourceText src)
1389        $! transint $ parseUnsignedInteger
1390        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
1391
1392 tok_num :: (Integer -> Integer)
1393         -> Int -> Int
1394         -> (Integer, (Char->Int)) -> Action
1395 tok_num = tok_integral $ \case
1396     st@(SourceText ('-':_)) -> itint st (const True)
1397     st@(SourceText _)       -> itint st (const False)
1398     st@NoSourceText         -> itint st (< 0)
1399   where
1400     itint :: SourceText -> (Integer -> Bool) -> Integer -> Token
1401     itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val)
1402
1403 tok_primint :: (Integer -> Integer)
1404             -> Int -> Int
1405             -> (Integer, (Char->Int)) -> Action
1406 tok_primint = tok_integral ITprimint
1407
1408
1409 tok_primword :: Int -> Int
1410              -> (Integer, (Char->Int)) -> Action
1411 tok_primword = tok_integral ITprimword positive
1412 positive, negative :: (Integer -> Integer)
1413 positive = id
1414 negative = negate
1415 decimal, octal, hexadecimal :: (Integer, Char -> Int)
1416 decimal = (10,octDecDigit)
1417 binary = (2,octDecDigit)
1418 octal = (8,octDecDigit)
1419 hexadecimal = (16,hexDigit)
1420
1421 -- readRational can understand negative rationals, exponents, everything.
1422 tok_frac :: Int -> (String -> Token) -> Action
1423 tok_frac drop f span buf len = do
1424   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
1425   let src = lexemeToString buf (len-drop)
1426   when ((not numericUnderscores) && ('_' `elem` src)) $ do
1427     pState <- getPState
1428     addError (RealSrcSpan (last_loc pState)) $ text
1429              "Use NumericUnderscores to allow underscores in floating literals"
1430   return (L span $! (f $! src))
1431
1432 tok_float, tok_primfloat, tok_primdouble :: String -> Token
1433 tok_float        str = ITrational   $! readFractionalLit str
1434 tok_hex_float    str = ITrational   $! readHexFractionalLit str
1435 tok_primfloat    str = ITprimfloat  $! readFractionalLit str
1436 tok_primdouble   str = ITprimdouble $! readFractionalLit str
1437
1438 readFractionalLit :: String -> FractionalLit
1439 readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
1440                         where is_neg = case str of ('-':_) -> True
1441                                                    _       -> False
1442 readHexFractionalLit :: String -> FractionalLit
1443 readHexFractionalLit str =
1444   FL { fl_text  = SourceText str
1445      , fl_neg   = case str of
1446                     '-' : _ -> True
1447                     _       -> False
1448      , fl_value = readHexRational str
1449      }
1450
1451 -- -----------------------------------------------------------------------------
1452 -- Layout processing
1453
1454 -- we're at the first token on a line, insert layout tokens if necessary
1455 do_bol :: Action
1456 do_bol span _str _len = do
1457         -- See Note [Nested comment line pragmas]
1458         b <- getBit InNestedCommentBit
1459         if b then return (L span ITcomment_line_prag) else do
1460           (pos, gen_semic) <- getOffside
1461           case pos of
1462               LT -> do
1463                   --trace "layout: inserting '}'" $ do
1464                   popContext
1465                   -- do NOT pop the lex state, we might have a ';' to insert
1466                   return (L span ITvccurly)
1467               EQ | gen_semic -> do
1468                   --trace "layout: inserting ';'" $ do
1469                   _ <- popLexState
1470                   return (L span ITsemi)
1471               _ -> do
1472                   _ <- popLexState
1473                   lexToken
1474
1475 -- certain keywords put us in the "layout" state, where we might
1476 -- add an opening curly brace.
1477 maybe_layout :: Token -> P ()
1478 maybe_layout t = do -- If the alternative layout rule is enabled then
1479                     -- we never create an implicit layout context here.
1480                     -- Layout is handled XXX instead.
1481                     -- The code for closing implicit contexts, or
1482                     -- inserting implicit semi-colons, is therefore
1483                     -- irrelevant as it only applies in an implicit
1484                     -- context.
1485                     alr <- getBit AlternativeLayoutRuleBit
1486                     unless alr $ f t
1487     where f ITdo    = pushLexState layout_do
1488           f ITmdo   = pushLexState layout_do
1489           f ITof    = pushLexState layout
1490           f ITlcase = pushLexState layout
1491           f ITlet   = pushLexState layout
1492           f ITwhere = pushLexState layout
1493           f ITrec   = pushLexState layout
1494           f ITif    = pushLexState layout_if
1495           f _       = return ()
1496
1497 -- Pushing a new implicit layout context.  If the indentation of the
1498 -- next token is not greater than the previous layout context, then
1499 -- Haskell 98 says that the new layout context should be empty; that is
1500 -- the lexer must generate {}.
1501 --
1502 -- We are slightly more lenient than this: when the new context is started
1503 -- by a 'do', then we allow the new context to be at the same indentation as
1504 -- the previous context.  This is what the 'strict' argument is for.
1505 new_layout_context :: Bool -> Bool -> Token -> Action
1506 new_layout_context strict gen_semic tok span _buf len = do
1507     _ <- popLexState
1508     (AI l _) <- getInput
1509     let offset = srcLocCol l - len
1510     ctx <- getContext
1511     nondecreasing <- getBit NondecreasingIndentationBit
1512     let strict' = strict || not nondecreasing
1513     case ctx of
1514         Layout prev_off _ : _  |
1515            (strict'     && prev_off >= offset  ||
1516             not strict' && prev_off > offset) -> do
1517                 -- token is indented to the left of the previous context.
1518                 -- we must generate a {} sequence now.
1519                 pushLexState layout_left
1520                 return (L span tok)
1521         _ -> do setContext (Layout offset gen_semic : ctx)
1522                 return (L span tok)
1523
1524 do_layout_left :: Action
1525 do_layout_left span _buf _len = do
1526     _ <- popLexState
1527     pushLexState bol  -- we must be at the start of a line
1528     return (L span ITvccurly)
1529
1530 -- -----------------------------------------------------------------------------
1531 -- LINE pragmas
1532
1533 setLineAndFile :: Int -> Action
1534 setLineAndFile code span buf len = do
1535   let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark
1536       linenumLen = length $ head $ words src
1537       linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit
1538       file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src
1539           -- skip everything through first quotation mark to get to the filename
1540         where go ('\\':c:cs) = c : go cs
1541               go (c:cs)      = c : go cs
1542               go []          = []
1543               -- decode escapes in the filename.  e.g. on Windows
1544               -- when our filenames have backslashes in, gcc seems to
1545               -- escape the backslashes.  One symptom of not doing this
1546               -- is that filenames in error messages look a bit strange:
1547               --   C:\\foo\bar.hs
1548               -- only the first backslash is doubled, because we apply
1549               -- System.FilePath.normalise before printing out
1550               -- filenames and it does not remove duplicate
1551               -- backslashes after the drive letter (should it?).
1552   setAlrLastLoc $ alrInitialLoc file
1553   setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))
1554       -- subtract one: the line number refers to the *following* line
1555   addSrcFile file
1556   _ <- popLexState
1557   pushLexState code
1558   lexToken
1559
1560 setColumn :: Action
1561 setColumn span buf len = do
1562   let column =
1563         case reads (lexemeToString buf len) of
1564           [(column, _)] -> column
1565           _ -> error "setColumn: expected integer" -- shouldn't happen
1566   setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)
1567                           (fromIntegral (column :: Integer)))
1568   _ <- popLexState
1569   lexToken
1570
1571 alrInitialLoc :: FastString -> RealSrcSpan
1572 alrInitialLoc file = mkRealSrcSpan loc loc
1573     where -- This is a hack to ensure that the first line in a file
1574           -- looks like it is after the initial location:
1575           loc = mkRealSrcLoc file (-1) (-1)
1576
1577 -- -----------------------------------------------------------------------------
1578 -- Options, includes and language pragmas.
1579
1580 lex_string_prag :: (String -> Token) -> Action
1581 lex_string_prag mkTok span _buf _len
1582     = do input <- getInput
1583          start <- getRealSrcLoc
1584          tok <- go [] input
1585          end <- getRealSrcLoc
1586          return (L (mkRealSrcSpan start end) tok)
1587     where go acc input
1588               = if isString input "#-}"
1589                    then do setInput input
1590                            return (mkTok (reverse acc))
1591                    else case alexGetChar input of
1592                           Just (c,i) -> go (c:acc) i
1593                           Nothing -> err input
1594           isString _ [] = True
1595           isString i (x:xs)
1596               = case alexGetChar i of
1597                   Just (c,i') | c == x    -> isString i' xs
1598                   _other -> False
1599           err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
1600
1601
1602 -- -----------------------------------------------------------------------------
1603 -- Strings & Chars
1604
1605 -- This stuff is horrible.  I hates it.
1606
1607 lex_string_tok :: Action
1608 lex_string_tok span buf _len = do
1609   tok <- lex_string ""
1610   (AI end bufEnd) <- getInput
1611   let
1612     tok' = case tok of
1613             ITprimstring _ bs -> ITprimstring (SourceText src) bs
1614             ITstring _ s -> ITstring (SourceText src) s
1615             _ -> panic "lex_string_tok"
1616     src = lexemeToString buf (cur bufEnd - cur buf)
1617   return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')
1618
1619 lex_string :: String -> P Token
1620 lex_string s = do
1621   i <- getInput
1622   case alexGetChar' i of
1623     Nothing -> lit_error i
1624
1625     Just ('"',i)  -> do
1626         setInput i
1627         let s' = reverse s
1628         magicHash <- getBit MagicHashBit
1629         if magicHash
1630           then do
1631             i <- getInput
1632             case alexGetChar' i of
1633               Just ('#',i) -> do
1634                 setInput i
1635                 when (any (> '\xFF') s') $ do
1636                   pState <- getPState
1637                   addError (RealSrcSpan (last_loc pState)) $ text
1638                      "primitive string literal must contain only characters <= \'\\xFF\'"
1639                 return (ITprimstring (SourceText s') (unsafeMkByteString s'))
1640               _other ->
1641                 return (ITstring (SourceText s') (mkFastString s'))
1642           else
1643                 return (ITstring (SourceText s') (mkFastString s'))
1644
1645     Just ('\\',i)
1646         | Just ('&',i) <- next -> do
1647                 setInput i; lex_string s
1648         | Just (c,i) <- next, c <= '\x7f' && is_space c -> do
1649                            -- is_space only works for <= '\x7f' (#3751, #5425)
1650                 setInput i; lex_stringgap s
1651         where next = alexGetChar' i
1652
1653     Just (c, i1) -> do
1654         case c of
1655           '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)
1656           c | isAny c -> do setInput i1; lex_string (c:s)
1657           _other -> lit_error i
1658
1659 lex_stringgap :: String -> P Token
1660 lex_stringgap s = do
1661   i <- getInput
1662   c <- getCharOrFail i
1663   case c of
1664     '\\' -> lex_string s
1665     c | c <= '\x7f' && is_space c -> lex_stringgap s
1666                            -- is_space only works for <= '\x7f' (#3751, #5425)
1667     _other -> lit_error i
1668
1669
1670 lex_char_tok :: Action
1671 -- Here we are basically parsing character literals, such as 'x' or '\n'
1672 -- but we additionally spot 'x and ''T, returning ITsimpleQuote and
1673 -- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part
1674 -- (the parser does that).
1675 -- So we have to do two characters of lookahead: when we see 'x we need to
1676 -- see if there's a trailing quote
1677 lex_char_tok span buf _len = do        -- We've seen '
1678    i1 <- getInput       -- Look ahead to first character
1679    let loc = realSrcSpanStart span
1680    case alexGetChar' i1 of
1681         Nothing -> lit_error  i1
1682
1683         Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''
1684                    setInput i2
1685                    return (L (mkRealSrcSpan loc end2)  ITtyQuote)
1686
1687         Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash
1688                   setInput i2
1689                   lit_ch <- lex_escape
1690                   i3 <- getInput
1691                   mc <- getCharOrFail i3 -- Trailing quote
1692                   if mc == '\'' then finish_char_tok buf loc lit_ch
1693                                 else lit_error i3
1694
1695         Just (c, i2@(AI _end2 _))
1696                 | not (isAny c) -> lit_error i1
1697                 | otherwise ->
1698
1699                 -- We've seen 'x, where x is a valid character
1700                 --  (i.e. not newline etc) but not a quote or backslash
1701            case alexGetChar' i2 of      -- Look ahead one more character
1702                 Just ('\'', i3) -> do   -- We've seen 'x'
1703                         setInput i3
1704                         finish_char_tok buf loc c
1705                 _other -> do            -- We've seen 'x not followed by quote
1706                                         -- (including the possibility of EOF)
1707                                         -- Just parse the quote only
1708                         let (AI end _) = i1
1709                         return (L (mkRealSrcSpan loc end) ITsimpleQuote)
1710
1711 finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)
1712 finish_char_tok buf loc ch  -- We've already seen the closing quote
1713                         -- Just need to check for trailing #
1714   = do  magicHash <- getBit MagicHashBit
1715         i@(AI end bufEnd) <- getInput
1716         let src = lexemeToString buf (cur bufEnd - cur buf)
1717         if magicHash then do
1718             case alexGetChar' i of
1719               Just ('#',i@(AI end _)) -> do
1720                 setInput i
1721                 return (L (mkRealSrcSpan loc end)
1722                           (ITprimchar (SourceText src) ch))
1723               _other ->
1724                 return (L (mkRealSrcSpan loc end)
1725                           (ITchar (SourceText src) ch))
1726             else do
1727               return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch))
1728
1729 isAny :: Char -> Bool
1730 isAny c | c > '\x7f' = isPrint c
1731         | otherwise  = is_any c
1732
1733 lex_escape :: P Char
1734 lex_escape = do
1735   i0 <- getInput
1736   c <- getCharOrFail i0
1737   case c of
1738         'a'   -> return '\a'
1739         'b'   -> return '\b'
1740         'f'   -> return '\f'
1741         'n'   -> return '\n'
1742         'r'   -> return '\r'
1743         't'   -> return '\t'
1744         'v'   -> return '\v'
1745         '\\'  -> return '\\'
1746         '"'   -> return '\"'
1747         '\''  -> return '\''
1748         '^'   -> do i1 <- getInput
1749                     c <- getCharOrFail i1
1750                     if c >= '@' && c <= '_'
1751                         then return (chr (ord c - ord '@'))
1752                         else lit_error i1
1753
1754         'x'   -> readNum is_hexdigit 16 hexDigit
1755         'o'   -> readNum is_octdigit  8 octDecDigit
1756         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1757
1758         c1 ->  do
1759            i <- getInput
1760            case alexGetChar' i of
1761             Nothing -> lit_error i0
1762             Just (c2,i2) ->
1763               case alexGetChar' i2 of
1764                 Nothing -> do lit_error i0
1765                 Just (c3,i3) ->
1766                    let str = [c1,c2,c3] in
1767                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1768                                      Just rest <- [stripPrefix p str] ] of
1769                           (escape_char,[]):_ -> do
1770                                 setInput i3
1771                                 return escape_char
1772                           (escape_char,_:_):_ -> do
1773                                 setInput i2
1774                                 return escape_char
1775                           [] -> lit_error i0
1776
1777 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1778 readNum is_digit base conv = do
1779   i <- getInput
1780   c <- getCharOrFail i
1781   if is_digit c
1782         then readNum2 is_digit base conv (conv c)
1783         else lit_error i
1784
1785 readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char
1786 readNum2 is_digit base conv i = do
1787   input <- getInput
1788   read i input
1789   where read i input = do
1790           case alexGetChar' input of
1791             Just (c,input') | is_digit c -> do
1792                let i' = i*base + conv c
1793                if i' > 0x10ffff
1794                   then setInput input >> lexError "numeric escape sequence out of range"
1795                   else read i' input'
1796             _other -> do
1797               setInput input; return (chr i)
1798
1799
1800 silly_escape_chars :: [(String, Char)]
1801 silly_escape_chars = [
1802         ("NUL", '\NUL'),
1803         ("SOH", '\SOH'),
1804         ("STX", '\STX'),
1805         ("ETX", '\ETX'),
1806         ("EOT", '\EOT'),
1807         ("ENQ", '\ENQ'),
1808         ("ACK", '\ACK'),
1809         ("BEL", '\BEL'),
1810         ("BS", '\BS'),
1811         ("HT", '\HT'),
1812         ("LF", '\LF'),
1813         ("VT", '\VT'),
1814         ("FF", '\FF'),
1815         ("CR", '\CR'),
1816         ("SO", '\SO'),
1817         ("SI", '\SI'),
1818         ("DLE", '\DLE'),
1819         ("DC1", '\DC1'),
1820         ("DC2", '\DC2'),
1821         ("DC3", '\DC3'),
1822         ("DC4", '\DC4'),
1823         ("NAK", '\NAK'),
1824         ("SYN", '\SYN'),
1825         ("ETB", '\ETB'),
1826         ("CAN", '\CAN'),
1827         ("EM", '\EM'),
1828         ("SUB", '\SUB'),
1829         ("ESC", '\ESC'),
1830         ("FS", '\FS'),
1831         ("GS", '\GS'),
1832         ("RS", '\RS'),
1833         ("US", '\US'),
1834         ("SP", '\SP'),
1835         ("DEL", '\DEL')
1836         ]
1837
1838 -- before calling lit_error, ensure that the current input is pointing to
1839 -- the position of the error in the buffer.  This is so that we can report
1840 -- a correct location to the user, but also so we can detect UTF-8 decoding
1841 -- errors if they occur.
1842 lit_error :: AlexInput -> P a
1843 lit_error i = do setInput i; lexError "lexical error in string/character literal"
1844
1845 getCharOrFail :: AlexInput -> P Char
1846 getCharOrFail i =  do
1847   case alexGetChar' i of
1848         Nothing -> lexError "unexpected end-of-file in string/character literal"
1849         Just (c,i)  -> do setInput i; return c
1850
1851 -- -----------------------------------------------------------------------------
1852 -- QuasiQuote
1853
1854 lex_qquasiquote_tok :: Action
1855 lex_qquasiquote_tok span buf len = do
1856   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
1857   quoteStart <- getRealSrcLoc
1858   quote <- lex_quasiquote quoteStart ""
1859   end <- getRealSrcLoc
1860   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1861            (ITqQuasiQuote (qual,
1862                            quoter,
1863                            mkFastString (reverse quote),
1864                            mkRealSrcSpan quoteStart end)))
1865
1866 lex_quasiquote_tok :: Action
1867 lex_quasiquote_tok span buf len = do
1868   let quoter = tail (lexemeToString buf (len - 1))
1869                 -- 'tail' drops the initial '[',
1870                 -- while the -1 drops the trailing '|'
1871   quoteStart <- getRealSrcLoc
1872   quote <- lex_quasiquote quoteStart ""
1873   end <- getRealSrcLoc
1874   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1875            (ITquasiQuote (mkFastString quoter,
1876                           mkFastString (reverse quote),
1877                           mkRealSrcSpan quoteStart end)))
1878
1879 lex_quasiquote :: RealSrcLoc -> String -> P String
1880 lex_quasiquote start s = do
1881   i <- getInput
1882   case alexGetChar' i of
1883     Nothing -> quasiquote_error start
1884
1885     -- NB: The string "|]" terminates the quasiquote,
1886     -- with absolutely no escaping. See the extensive
1887     -- discussion on #5348 for why there is no
1888     -- escape handling.
1889     Just ('|',i)
1890         | Just (']',i) <- alexGetChar' i
1891         -> do { setInput i; return s }
1892
1893     Just (c, i) -> do
1894          setInput i; lex_quasiquote start (c : s)
1895
1896 quasiquote_error :: RealSrcLoc -> P a
1897 quasiquote_error start = do
1898   (AI end buf) <- getInput
1899   reportLexError start end buf "unterminated quasiquotation"
1900
1901 -- -----------------------------------------------------------------------------
1902 -- Warnings
1903
1904 warnTab :: Action
1905 warnTab srcspan _buf _len = do
1906     addTabWarning srcspan
1907     lexToken
1908
1909 warnThen :: WarningFlag -> SDoc -> Action -> Action
1910 warnThen option warning action srcspan buf len = do
1911     addWarning option (RealSrcSpan srcspan) warning
1912     action srcspan buf len
1913
1914 -- -----------------------------------------------------------------------------
1915 -- The Parse Monad
1916
1917 -- | Do we want to generate ';' layout tokens? In some cases we just want to
1918 -- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates
1919 -- alternatives (unlike a `case` expression where we need ';' to as a separator
1920 -- between alternatives).
1921 type GenSemic = Bool
1922
1923 generateSemic, dontGenerateSemic :: GenSemic
1924 generateSemic     = True
1925 dontGenerateSemic = False
1926
1927 data LayoutContext
1928   = NoLayout
1929   | Layout !Int !GenSemic
1930   deriving Show
1931
1932 -- | The result of running a parser.
1933 data ParseResult a
1934   = POk      -- ^ The parser has consumed a (possibly empty) prefix
1935              --   of the input and produced a result. Use 'getMessages'
1936              --   to check for accumulated warnings and non-fatal errors.
1937       PState -- ^ The resulting parsing state. Can be used to resume parsing.
1938       a      -- ^ The resulting value.
1939   | PFailed  -- ^ The parser has consumed a (possibly empty) prefix
1940              --   of the input and failed.
1941       PState -- ^ The parsing state right before failure, including the fatal
1942              --   parse error. 'getMessages' and 'getErrorMessages' must return
1943              --   a non-empty bag of errors.
1944
1945 -- | Test whether a 'WarningFlag' is set
1946 warnopt :: WarningFlag -> ParserFlags -> Bool
1947 warnopt f options = f `EnumSet.member` pWarningFlags options
1948
1949 -- | The subset of the 'DynFlags' used by the parser.
1950 -- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this.
1951 data ParserFlags = ParserFlags {
1952     pWarningFlags   :: EnumSet WarningFlag
1953   , pThisPackage    :: UnitId      -- ^ key of package currently being compiled
1954   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
1955   }
1956
1957 data PState = PState {
1958         buffer     :: StringBuffer,
1959         options    :: ParserFlags,
1960         -- This needs to take DynFlags as an argument until
1961         -- we have a fix for #10143
1962         messages   :: DynFlags -> Messages,
1963         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file
1964         tab_count  :: !Int,              -- number of tab warnings in the file
1965         last_tk    :: Maybe Token,
1966         last_loc   :: RealSrcSpan, -- pos of previous token
1967         last_len   :: !Int,        -- len of previous token
1968         loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)
1969         context    :: [LayoutContext],
1970         lex_state  :: [Int],
1971         srcfiles   :: [FastString],
1972         -- Used in the alternative layout rule:
1973         -- These tokens are the next ones to be sent out. They are
1974         -- just blindly emitted, without the rule looking at them again:
1975         alr_pending_implicit_tokens :: [RealLocated Token],
1976         -- This is the next token to be considered or, if it is Nothing,
1977         -- we need to get the next token from the input stream:
1978         alr_next_token :: Maybe (RealLocated Token),
1979         -- This is what we consider to be the location of the last token
1980         -- emitted:
1981         alr_last_loc :: RealSrcSpan,
1982         -- The stack of layout contexts:
1983         alr_context :: [ALRContext],
1984         -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
1985         -- us what sort of layout the '{' will open:
1986         alr_expecting_ocurly :: Maybe ALRLayout,
1987         -- Have we just had the '}' for a let block? If so, than an 'in'
1988         -- token doesn't need to close anything:
1989         alr_justClosedExplicitLetBlock :: Bool,
1990
1991         -- The next three are used to implement Annotations giving the
1992         -- locations of 'noise' tokens in the source, so that users of
1993         -- the GHC API can do source to source conversions.
1994         -- See note [Api annotations] in ApiAnnotation.hs
1995         annotations :: [(ApiAnnKey,[SrcSpan])],
1996         comment_q :: [Located AnnotationComment],
1997         annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
1998      }
1999         -- last_loc and last_len are used when generating error messages,
2000         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
2001         -- current token to happyError, we could at least get rid of last_len.
2002         -- Getting rid of last_loc would require finding another way to
2003         -- implement pushCurrentContext (which is only called from one place).
2004
2005 data ALRContext = ALRNoLayout Bool{- does it contain commas? -}
2006                               Bool{- is it a 'let' block? -}
2007                 | ALRLayout ALRLayout Int
2008 data ALRLayout = ALRLayoutLet
2009                | ALRLayoutWhere
2010                | ALRLayoutOf
2011                | ALRLayoutDo
2012
2013 -- | The parsing monad, isomorphic to @StateT PState Maybe@.
2014 newtype P a = P { unP :: PState -> ParseResult a }
2015
2016 instance Functor P where
2017   fmap = liftM
2018
2019 instance Applicative P where
2020   pure = returnP
2021   (<*>) = ap
2022
2023 instance Monad P where
2024   (>>=) = thenP
2025 #if !MIN_VERSION_base(4,13,0)
2026   fail = MonadFail.fail
2027 #endif
2028
2029 instance MonadFail.MonadFail P where
2030   fail = failMsgP
2031
2032 returnP :: a -> P a
2033 returnP a = a `seq` (P $ \s -> POk s a)
2034
2035 thenP :: P a -> (a -> P b) -> P b
2036 (P m) `thenP` k = P $ \ s ->
2037         case m s of
2038                 POk s1 a         -> (unP (k a)) s1
2039                 PFailed s1 -> PFailed s1
2040
2041 failMsgP :: String -> P a
2042 failMsgP msg = do
2043   pState <- getPState
2044   addFatalError (RealSrcSpan (last_loc pState)) (text msg)
2045
2046 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
2047 failLocMsgP loc1 loc2 str =
2048   addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
2049
2050 getPState :: P PState
2051 getPState = P $ \s -> POk s s
2052
2053 withThisPackage :: (UnitId -> a) -> P a
2054 withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o))
2055
2056 getExts :: P ExtsBitmap
2057 getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
2058
2059 setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()
2060 setExts f = P $ \s -> POk s {
2061   options =
2062     let p = options s
2063     in  p { pExtsBitmap = f (pExtsBitmap p) }
2064   } ()
2065
2066 setSrcLoc :: RealSrcLoc -> P ()
2067 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
2068
2069 getRealSrcLoc :: P RealSrcLoc
2070 getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
2071
2072 addSrcFile :: FastString -> P ()
2073 addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
2074
2075 setLastToken :: RealSrcSpan -> Int -> P ()
2076 setLastToken loc len = P $ \s -> POk s {
2077   last_loc=loc,
2078   last_len=len
2079   } ()
2080
2081 setLastTk :: Token -> P ()
2082 setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
2083
2084 getLastTk :: P (Maybe Token)
2085 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
2086
2087 data AlexInput = AI RealSrcLoc StringBuffer
2088
2089 {-
2090 Note [Unicode in Alex]
2091 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2092 Although newer versions of Alex support unicode, this grammar is processed with
2093 the old style '--latin1' behaviour. This means that when implementing the
2094 functions
2095
2096     alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)
2097     alexInputPrevChar :: AlexInput -> Char
2098
2099 which Alex uses to take apart our 'AlexInput', we must
2100
2101   * return a latin1 character in the 'Word8' that 'alexGetByte' expects
2102   * return a latin1 character in 'alexInputPrevChar'.
2103
2104 We handle this in 'adjustChar' by squishing entire classes of unicode
2105 characters into single bytes.
2106 -}
2107
2108 {-# INLINE adjustChar #-}
2109 adjustChar :: Char -> Word8
2110 adjustChar c = fromIntegral $ ord adj_c
2111   where non_graphic     = '\x00'
2112         upper           = '\x01'
2113         lower           = '\x02'
2114         digit           = '\x03'
2115         symbol          = '\x04'
2116         space           = '\x05'
2117         other_graphic   = '\x06'
2118         uniidchar       = '\x07'
2119
2120         adj_c
2121           | c <= '\x07' = non_graphic
2122           | c <= '\x7f' = c
2123           -- Alex doesn't handle Unicode, so when Unicode
2124           -- character is encountered we output these values
2125           -- with the actual character value hidden in the state.
2126           | otherwise =
2127                 -- NB: The logic behind these definitions is also reflected
2128                 -- in basicTypes/Lexeme.hs
2129                 -- Any changes here should likely be reflected there.
2130
2131                 case generalCategory c of
2132                   UppercaseLetter       -> upper
2133                   LowercaseLetter       -> lower
2134                   TitlecaseLetter       -> upper
2135                   ModifierLetter        -> uniidchar -- see #10196
2136                   OtherLetter           -> lower -- see #1103
2137                   NonSpacingMark        -> uniidchar -- see #7650
2138                   SpacingCombiningMark  -> other_graphic
2139                   EnclosingMark         -> other_graphic
2140                   DecimalNumber         -> digit
2141                   LetterNumber          -> other_graphic
2142                   OtherNumber           -> digit -- see #4373
2143                   ConnectorPunctuation  -> symbol
2144                   DashPunctuation       -> symbol
2145                   OpenPunctuation       -> other_graphic
2146                   ClosePunctuation      -> other_graphic
2147                   InitialQuote          -> other_graphic
2148                   FinalQuote            -> other_graphic
2149                   OtherPunctuation      -> symbol
2150                   MathSymbol            -> symbol
2151                   CurrencySymbol        -> symbol
2152                   ModifierSymbol        -> symbol
2153                   OtherSymbol           -> symbol
2154                   Space                 -> space
2155                   _other                -> non_graphic
2156
2157 -- Getting the previous 'Char' isn't enough here - we need to convert it into
2158 -- the same format that 'alexGetByte' would have produced.
2159 --
2160 -- See Note [Unicode in Alex] and #13986.
2161 alexInputPrevChar :: AlexInput -> Char
2162 alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))
2163   where pc = prevChar buf '\n'
2164
2165 -- backwards compatibility for Alex 2.x
2166 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
2167 alexGetChar inp = case alexGetByte inp of
2168                     Nothing    -> Nothing
2169                     Just (b,i) -> c `seq` Just (c,i)
2170                        where c = chr $ fromIntegral b
2171
2172 -- See Note [Unicode in Alex]
2173 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
2174 alexGetByte (AI loc s)
2175   | atEnd s   = Nothing
2176   | otherwise = byte `seq` loc' `seq` s' `seq`
2177                 --trace (show (ord c)) $
2178                 Just (byte, (AI loc' s'))
2179   where (c,s') = nextChar s
2180         loc'   = advanceSrcLoc loc c
2181         byte   = adjustChar c
2182
2183 -- This version does not squash unicode characters, it is used when
2184 -- lexing strings.
2185 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
2186 alexGetChar' (AI loc s)
2187   | atEnd s   = Nothing
2188   | otherwise = c `seq` loc' `seq` s' `seq`
2189                 --trace (show (ord c)) $
2190                 Just (c, (AI loc' s'))
2191   where (c,s') = nextChar s
2192         loc'   = advanceSrcLoc loc c
2193
2194 getInput :: P AlexInput
2195 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
2196
2197 setInput :: AlexInput -> P ()
2198 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
2199
2200 nextIsEOF :: P Bool
2201 nextIsEOF = do
2202   AI _ s <- getInput
2203   return $ atEnd s
2204
2205 pushLexState :: Int -> P ()
2206 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
2207
2208 popLexState :: P Int
2209 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
2210
2211 getLexState :: P Int
2212 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
2213
2214 popNextToken :: P (Maybe (RealLocated Token))
2215 popNextToken
2216     = P $ \s@PState{ alr_next_token = m } ->
2217               POk (s {alr_next_token = Nothing}) m
2218
2219 activeContext :: P Bool
2220 activeContext = do
2221   ctxt <- getALRContext
2222   expc <- getAlrExpectingOCurly
2223   impt <- implicitTokenPending
2224   case (ctxt,expc) of
2225     ([],Nothing) -> return impt
2226     _other       -> return True
2227
2228 setAlrLastLoc :: RealSrcSpan -> P ()
2229 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
2230
2231 getAlrLastLoc :: P RealSrcSpan
2232 getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
2233
2234 getALRContext :: P [ALRContext]
2235 getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
2236
2237 setALRContext :: [ALRContext] -> P ()
2238 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
2239
2240 getJustClosedExplicitLetBlock :: P Bool
2241 getJustClosedExplicitLetBlock
2242  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
2243
2244 setJustClosedExplicitLetBlock :: Bool -> P ()
2245 setJustClosedExplicitLetBlock b
2246  = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
2247
2248 setNextToken :: RealLocated Token -> P ()
2249 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
2250
2251 implicitTokenPending :: P Bool
2252 implicitTokenPending
2253     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
2254               case ts of
2255               [] -> POk s False
2256               _  -> POk s True
2257
2258 popPendingImplicitToken :: P (Maybe (RealLocated Token))
2259 popPendingImplicitToken
2260     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
2261               case ts of
2262               [] -> POk s Nothing
2263               (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
2264
2265 setPendingImplicitTokens :: [RealLocated Token] -> P ()
2266 setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
2267
2268 getAlrExpectingOCurly :: P (Maybe ALRLayout)
2269 getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
2270
2271 setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
2272 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
2273
2274 -- | For reasons of efficiency, boolean parsing flags (eg, language extensions
2275 -- or whether we are currently in a @RULE@ pragma) are represented by a bitmap
2276 -- stored in a @Word64@.
2277 type ExtsBitmap = Word64
2278
2279 xbit :: ExtBits -> ExtsBitmap
2280 xbit = bit . fromEnum
2281
2282 xtest :: ExtBits -> ExtsBitmap -> Bool
2283 xtest ext xmap = testBit xmap (fromEnum ext)
2284
2285 -- | Various boolean flags, mostly language extensions, that impact lexing and
2286 -- parsing. Note that a handful of these can change during lexing/parsing.
2287 data ExtBits
2288   -- Flags that are constant once parsing starts
2289   = FfiBit
2290   | InterruptibleFfiBit
2291   | CApiFfiBit
2292   | ArrowsBit
2293   | ThBit
2294   | ThQuotesBit
2295   | IpBit
2296   | OverloadedLabelsBit -- #x overloaded labels
2297   | ExplicitForallBit -- the 'forall' keyword
2298   | BangPatBit -- Tells the parser to understand bang-patterns
2299                -- (doesn't affect the lexer)
2300   | PatternSynonymsBit -- pattern synonyms
2301   | HaddockBit-- Lex and parse Haddock comments
2302   | MagicHashBit -- "#" in both functions and operators
2303   | RecursiveDoBit -- mdo
2304   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
2305   | UnboxedTuplesBit -- (# and #)
2306   | UnboxedSumsBit -- (# and #)
2307   | DatatypeContextsBit
2308   | MonadComprehensionsBit
2309   | TransformComprehensionsBit
2310   | QqBit -- enable quasiquoting
2311   | RawTokenStreamBit -- producing a token stream with all comments included
2312   | AlternativeLayoutRuleBit
2313   | ALRTransitionalBit
2314   | RelaxedLayoutBit
2315   | NondecreasingIndentationBit
2316   | SafeHaskellBit
2317   | TraditionalRecordSyntaxBit
2318   | ExplicitNamespacesBit
2319   | LambdaCaseBit
2320   | BinaryLiteralsBit
2321   | NegativeLiteralsBit
2322   | HexFloatLiteralsBit
2323   | TypeApplicationsBit
2324   | StaticPointersBit
2325   | NumericUnderscoresBit
2326   | StarIsTypeBit
2327   | BlockArgumentsBit
2328   | NPlusKPatternsBit
2329   | DoAndIfThenElseBit
2330   | MultiWayIfBit
2331   | GadtSyntaxBit
2332
2333   -- Flags that are updated once parsing starts
2334   | InRulePragBit
2335   | InNestedCommentBit -- See Note [Nested comment line pragmas]
2336   | UsePosPragsBit
2337     -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'
2338     -- update the internal position. Otherwise, those pragmas are lexed as
2339     -- tokens of their own.
2340   deriving Enum
2341
2342
2343
2344
2345
2346 -- PState for parsing options pragmas
2347 --
2348 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2349 pragState dynflags buf loc = (mkPState dynflags buf loc) {
2350                                  lex_state = [bol, option_prags, 0]
2351                              }
2352
2353 {-# INLINE mkParserFlags' #-}
2354 mkParserFlags'
2355   :: EnumSet WarningFlag        -- ^ warnings flags enabled
2356   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
2357   -> UnitId                     -- ^ key of package currently being compiled
2358   -> Bool                       -- ^ are safe imports on?
2359   -> Bool                       -- ^ keeping Haddock comment tokens
2360   -> Bool                       -- ^ keep regular comment tokens
2361
2362   -> Bool
2363   -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update
2364   -- the internal position kept by the parser. Otherwise, those pragmas are
2365   -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.
2366
2367   -> ParserFlags
2368 -- ^ Given exactly the information needed, set up the 'ParserFlags'
2369 mkParserFlags' warningFlags extensionFlags thisPackage
2370   safeImports isHaddock rawTokStream usePosPrags =
2371     ParserFlags {
2372       pWarningFlags = warningFlags
2373     , pThisPackage = thisPackage
2374     , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
2375     }
2376   where
2377     safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
2378     langExtBits =
2379           FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface
2380       .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI
2381       .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI
2382       .|. ArrowsBit                   `xoptBit` LangExt.Arrows
2383       .|. ThBit                       `xoptBit` LangExt.TemplateHaskell
2384       .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes
2385       .|. QqBit                       `xoptBit` LangExt.QuasiQuotes
2386       .|. IpBit                       `xoptBit` LangExt.ImplicitParams
2387       .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels
2388       .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll
2389       .|. BangPatBit                  `xoptBit` LangExt.BangPatterns
2390       .|. MagicHashBit                `xoptBit` LangExt.MagicHash
2391       .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo
2392       .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax
2393       .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples
2394       .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums
2395       .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts
2396       .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp
2397       .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions
2398       .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule
2399       .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional
2400       .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout
2401       .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation
2402       .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax
2403       .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces
2404       .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase
2405       .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals
2406       .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals
2407       .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals
2408       .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms
2409       .|. TypeApplicationsBit         `xoptBit` LangExt.TypeApplications
2410       .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers
2411       .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores
2412       .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType
2413       .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments
2414       .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns
2415       .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse
2416       .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf
2417       .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax
2418     optBits =
2419           HaddockBit        `setBitIf` isHaddock
2420       .|. RawTokenStreamBit `setBitIf` rawTokStream
2421       .|. UsePosPragsBit    `setBitIf` usePosPrags
2422
2423     xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
2424
2425     setBitIf :: ExtBits -> Bool -> ExtsBitmap
2426     b `setBitIf` cond | cond      = xbit b
2427                       | otherwise = 0
2428
2429 -- | Extracts the flag information needed for parsing
2430 mkParserFlags :: DynFlags -> ParserFlags
2431 mkParserFlags =
2432   mkParserFlags'
2433     <$> DynFlags.warningFlags
2434     <*> DynFlags.extensionFlags
2435     <*> DynFlags.thisPackage
2436     <*> safeImportsOn
2437     <*> gopt Opt_Haddock
2438     <*> gopt Opt_KeepRawTokenStream
2439     <*> const True
2440
2441 -- | Creates a parse state from a 'DynFlags' value
2442 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2443 mkPState flags = mkPStatePure (mkParserFlags flags)
2444
2445 -- | Creates a parse state from a 'ParserFlags' value
2446 mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
2447 mkPStatePure options buf loc =
2448   PState {
2449       buffer        = buf,
2450       options       = options,
2451       messages      = const emptyMessages,
2452       tab_first     = Nothing,
2453       tab_count     = 0,
2454       last_tk       = Nothing,
2455       last_loc      = mkRealSrcSpan loc loc,
2456       last_len      = 0,
2457       loc           = loc,
2458       context       = [],
2459       lex_state     = [bol, 0],
2460       srcfiles      = [],
2461       alr_pending_implicit_tokens = [],
2462       alr_next_token = Nothing,
2463       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
2464       alr_context = [],
2465       alr_expecting_ocurly = Nothing,
2466       alr_justClosedExplicitLetBlock = False,
2467       annotations = [],
2468       comment_q = [],
2469       annotations_comments = []
2470     }
2471
2472 -- | An mtl-style class for monads that support parsing-related operations.
2473 -- For example, sometimes we make a second pass over the parsing results to validate,
2474 -- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume
2475 -- input but can report parsing errors, check for extension bits, and accumulate
2476 -- parsing annotations. Both P and PV are instances of MonadP.
2477 --
2478 -- MonadP grants us convenient overloading. The other option is to have separate operations
2479 -- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.
2480 --
2481 class Monad m => MonadP m where
2482   -- | Add a non-fatal error. Use this when the parser can produce a result
2483   --   despite the error.
2484   --
2485   --   For example, when GHC encounters a @forall@ in a type,
2486   --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
2487   --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
2488   --   the accumulator.
2489   --
2490   --   Control flow wise, non-fatal errors act like warnings: they are added
2491   --   to the accumulator and parsing continues. This allows GHC to report
2492   --   more than one parse error per file.
2493   --
2494   addError :: SrcSpan -> SDoc -> m ()
2495   -- | Add a warning to the accumulator.
2496   --   Use 'getMessages' to get the accumulated warnings.
2497   addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()
2498   -- | Add a fatal error. This will be the last error reported by the parser, and
2499   --   the parser will not produce any result, ending in a 'PFailed' state.
2500   addFatalError :: SrcSpan -> SDoc -> m a
2501   -- | Check if a given flag is currently set in the bitmap.
2502   getBit :: ExtBits -> m Bool
2503   -- | Given a location and a list of AddAnn, apply them all to the location.
2504   addAnnsAt :: SrcSpan -> [AddAnn] -> m ()
2505   addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
2506                 -> AnnKeywordId     -- The first two parameters are the key
2507                 -> SrcSpan          -- The location of the keyword itself
2508                 -> m ()
2509
2510 instance MonadP P where
2511   addError srcspan msg
2512    = P $ \s@PState{messages=m} ->
2513          let
2514              m' d =
2515                  let (ws, es) = m d
2516                      errormsg = mkErrMsg d srcspan alwaysQualify msg
2517                      es' = es `snocBag` errormsg
2518                  in (ws, es')
2519          in POk s{messages=m'} ()
2520   addWarning option srcspan warning
2521    = P $ \s@PState{messages=m, options=o} ->
2522          let
2523              m' d =
2524                  let (ws, es) = m d
2525                      warning' = makeIntoWarning (Reason option) $
2526                         mkWarnMsg d srcspan alwaysQualify warning
2527                      ws' = if warnopt option o then ws `snocBag` warning' else ws
2528                  in (ws', es)
2529          in POk s{messages=m'} ()
2530   addFatalError span msg =
2531     addError span msg >> P PFailed
2532   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
2533                          in b `seq` POk s b
2534   addAnnsAt loc anns = mapM_ (\a -> a loc) anns
2535   addAnnotation l a v = do
2536     addAnnotationOnly l a v
2537     allocateComments l
2538
2539 addTabWarning :: RealSrcSpan -> P ()
2540 addTabWarning srcspan
2541  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
2542        let tf' = if isJust tf then tf else Just srcspan
2543            tc' = tc + 1
2544            s' = if warnopt Opt_WarnTabs o
2545                 then s{tab_first = tf', tab_count = tc'}
2546                 else s
2547        in POk s' ()
2548
2549 mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
2550 mkTabWarning PState{tab_first=tf, tab_count=tc} d =
2551   let middle = if tc == 1
2552         then text ""
2553         else text ", and in" <+> speakNOf (tc - 1) (text "further location")
2554       message = text "Tab character found here"
2555                 <> middle
2556                 <> text "."
2557                 $+$ text "Please use spaces instead."
2558   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
2559                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
2560
2561 -- | Get a bag of the errors that have been accumulated so far.
2562 --   Does not take -Werror into account.
2563 getErrorMessages :: PState -> DynFlags -> ErrorMessages
2564 getErrorMessages PState{messages=m} d =
2565   let (_, es) = m d in es
2566
2567 -- | Get the warnings and errors accumulated so far.
2568 --   Does not take -Werror into account.
2569 getMessages :: PState -> DynFlags -> Messages
2570 getMessages p@PState{messages=m} d =
2571   let (ws, es) = m d
2572       tabwarning = mkTabWarning p d
2573       ws' = maybe ws (`consBag` ws) tabwarning
2574   in (ws', es)
2575
2576 getContext :: P [LayoutContext]
2577 getContext = P $ \s@PState{context=ctx} -> POk s ctx
2578
2579 setContext :: [LayoutContext] -> P ()
2580 setContext ctx = P $ \s -> POk s{context=ctx} ()
2581
2582 popContext :: P ()
2583 popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
2584                               last_len = len, last_loc = last_loc }) ->
2585   case ctx of
2586         (_:tl) ->
2587           POk s{ context = tl } ()
2588         []     ->
2589           unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
2590
2591 -- Push a new layout context at the indentation of the last token read.
2592 pushCurrentContext :: GenSemic -> P ()
2593 pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->
2594     POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} ()
2595
2596 -- This is only used at the outer level of a module when the 'module' keyword is
2597 -- missing.
2598 pushModuleContext :: P ()
2599 pushModuleContext = pushCurrentContext generateSemic
2600
2601 getOffside :: P (Ordering, Bool)
2602 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
2603                 let offs = srcSpanStartCol loc in
2604                 let ord = case stk of
2605                             Layout n gen_semic : _ ->
2606                               --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
2607                               (compare offs n, gen_semic)
2608                             _ ->
2609                               (GT, dontGenerateSemic)
2610                 in POk s ord
2611
2612 -- ---------------------------------------------------------------------------
2613 -- Construct a parse error
2614
2615 srcParseErr
2616   :: ParserFlags
2617   -> StringBuffer       -- current buffer (placed just after the last token)
2618   -> Int                -- length of the previous token
2619   -> MsgDoc
2620 srcParseErr options buf len
2621   = if null token
2622          then text "parse error (possibly incorrect indentation or mismatched brackets)"
2623          else text "parse error on input" <+> quotes (text token)
2624               $$ ppWhen (not th_enabled && token == "$") -- #7396
2625                         (text "Perhaps you intended to use TemplateHaskell")
2626               $$ ppWhen (token == "<-")
2627                         (if mdoInLast100
2628                            then text "Perhaps you intended to use RecursiveDo"
2629                            else text "Perhaps this statement should be within a 'do' block?")
2630               $$ ppWhen (token == "=" && doInLast100) -- #15849
2631                         (text "Perhaps you need a 'let' in a 'do' block?"
2632                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
2633               $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429
2634                         (text "Perhaps you intended to use PatternSynonyms")
2635   where token = lexemeToString (offsetBytes (-len) buf) len
2636         pattern = decodePrevNChars 8 buf
2637         last100 = decodePrevNChars 100 buf
2638         doInLast100 = "do" `isInfixOf` last100
2639         mdoInLast100 = "mdo" `isInfixOf` last100
2640         th_enabled = ThBit `xtest` pExtsBitmap options
2641         ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
2642
2643 -- Report a parse failure, giving the span of the previous token as
2644 -- the location of the error.  This is the entry point for errors
2645 -- detected during parsing.
2646 srcParseFail :: P a
2647 srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
2648                             last_loc = last_loc } ->
2649     unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
2650
2651 -- A lexical error is reported at a particular position in the source file,
2652 -- not over a token range.
2653 lexError :: String -> P a
2654 lexError str = do
2655   loc <- getRealSrcLoc
2656   (AI end buf) <- getInput
2657   reportLexError loc end buf str
2658
2659 -- -----------------------------------------------------------------------------
2660 -- This is the top-level function: called from the parser each time a
2661 -- new token is to be read from the input.
2662
2663 lexer :: Bool -> (Located Token -> P a) -> P a
2664 lexer queueComments cont = do
2665   alr <- getBit AlternativeLayoutRuleBit
2666   let lexTokenFun = if alr then lexTokenAlr else lexToken
2667   (L span tok) <- lexTokenFun
2668   --trace ("token: " ++ show tok) $ do
2669
2670   case tok of
2671     ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
2672     _ -> return ()
2673
2674   if (queueComments && isDocComment tok)
2675     then queueComment (L (RealSrcSpan span) tok)
2676     else return ()
2677
2678   if (queueComments && isComment tok)
2679     then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
2680     else cont (L (RealSrcSpan span) tok)
2681
2682 lexTokenAlr :: P (RealLocated Token)
2683 lexTokenAlr = do mPending <- popPendingImplicitToken
2684                  t <- case mPending of
2685                       Nothing ->
2686                           do mNext <- popNextToken
2687                              t <- case mNext of
2688                                   Nothing -> lexToken
2689                                   Just next -> return next
2690                              alternativeLayoutRuleToken t
2691                       Just t ->
2692                           return t
2693                  setAlrLastLoc (getRealSrcSpan t)
2694                  case unRealSrcSpan t of
2695                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2696                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2697                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2698                      ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf)
2699                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2700                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2701                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2702                      _       -> return ()
2703                  return t
2704
2705 alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
2706 alternativeLayoutRuleToken t
2707     = do context <- getALRContext
2708          lastLoc <- getAlrLastLoc
2709          mExpectingOCurly <- getAlrExpectingOCurly
2710          transitional <- getBit ALRTransitionalBit
2711          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2712          setJustClosedExplicitLetBlock False
2713          let thisLoc = getRealSrcSpan t
2714              thisCol = srcSpanStartCol thisLoc
2715              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
2716          case (unRealSrcSpan t, context, mExpectingOCurly) of
2717              -- This case handles a GHC extension to the original H98
2718              -- layout rule...
2719              (ITocurly, _, Just alrLayout) ->
2720                  do setAlrExpectingOCurly Nothing
2721                     let isLet = case alrLayout of
2722                                 ALRLayoutLet -> True
2723                                 _ -> False
2724                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2725                     return t
2726              -- ...and makes this case unnecessary
2727              {-
2728              -- I think our implicit open-curly handling is slightly
2729              -- different to John's, in how it interacts with newlines
2730              -- and "in"
2731              (ITocurly, _, Just _) ->
2732                  do setAlrExpectingOCurly Nothing
2733                     setNextToken t
2734                     lexTokenAlr
2735              -}
2736              (_, ALRLayout _ col : _ls, Just expectingOCurly)
2737               | (thisCol > col) ||
2738                 (thisCol == col &&
2739                  isNonDecreasingIndentation expectingOCurly) ->
2740                  do setAlrExpectingOCurly Nothing
2741                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2742                     setNextToken t
2743                     return (L thisLoc ITvocurly)
2744               | otherwise ->
2745                  do setAlrExpectingOCurly Nothing
2746                     setPendingImplicitTokens [L lastLoc ITvccurly]
2747                     setNextToken t
2748                     return (L lastLoc ITvocurly)
2749              (_, _, Just expectingOCurly) ->
2750                  do setAlrExpectingOCurly Nothing
2751                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2752                     setNextToken t
2753                     return (L thisLoc ITvocurly)
2754              -- We do the [] cases earlier than in the spec, as we
2755              -- have an actual EOF token
2756              (ITeof, ALRLayout _ _ : ls, _) ->
2757                  do setALRContext ls
2758                     setNextToken t
2759                     return (L thisLoc ITvccurly)
2760              (ITeof, _, _) ->
2761                  return t
2762              -- the other ITeof case omitted; general case below covers it
2763              (ITin, _, _)
2764               | justClosedExplicitLetBlock ->
2765                  return t
2766              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2767               | newLine ->
2768                  do setPendingImplicitTokens [t]
2769                     setALRContext ls
2770                     return (L thisLoc ITvccurly)
2771              -- This next case is to handle a transitional issue:
2772              (ITwhere, ALRLayout _ col : ls, _)
2773               | newLine && thisCol == col && transitional ->
2774                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2775                                (RealSrcSpan thisLoc)
2776                                (transitionalAlternativeLayoutWarning
2777                                     "`where' clause at the same depth as implicit layout block")
2778                     setALRContext ls
2779                     setNextToken t
2780                     -- Note that we use lastLoc, as we may need to close
2781                     -- more layouts, or give a semicolon
2782                     return (L lastLoc ITvccurly)
2783              -- This next case is to handle a transitional issue:
2784              (ITvbar, ALRLayout _ col : ls, _)
2785               | newLine && thisCol == col && transitional ->
2786                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2787                                (RealSrcSpan thisLoc)
2788                                (transitionalAlternativeLayoutWarning
2789                                     "`|' at the same depth as implicit layout block")
2790                     setALRContext ls
2791                     setNextToken t
2792                     -- Note that we use lastLoc, as we may need to close
2793                     -- more layouts, or give a semicolon
2794                     return (L lastLoc ITvccurly)
2795              (_, ALRLayout _ col : ls, _)
2796               | newLine && thisCol == col ->
2797                  do setNextToken t
2798                     let loc = realSrcSpanStart thisLoc
2799                         zeroWidthLoc = mkRealSrcSpan loc loc
2800                     return (L zeroWidthLoc ITsemi)
2801               | newLine && thisCol < col ->
2802                  do setALRContext ls
2803                     setNextToken t
2804                     -- Note that we use lastLoc, as we may need to close
2805                     -- more layouts, or give a semicolon
2806                     return (L lastLoc ITvccurly)
2807              -- We need to handle close before open, as 'then' is both
2808              -- an open and a close
2809              (u, _, _)
2810               | isALRclose u ->
2811                  case context of
2812                  ALRLayout _ _ : ls ->
2813                      do setALRContext ls
2814                         setNextToken t
2815                         return (L thisLoc ITvccurly)
2816                  ALRNoLayout _ isLet : ls ->
2817                      do let ls' = if isALRopen u
2818                                      then ALRNoLayout (containsCommas u) False : ls
2819                                      else ls
2820                         setALRContext ls'
2821                         when isLet $ setJustClosedExplicitLetBlock True
2822                         return t
2823                  [] ->
2824                      do let ls = if isALRopen u
2825                                     then [ALRNoLayout (containsCommas u) False]
2826                                     else []
2827                         setALRContext ls
2828                         -- XXX This is an error in John's code, but
2829                         -- it looks reachable to me at first glance
2830                         return t
2831              (u, _, _)
2832               | isALRopen u ->
2833                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2834                     return t
2835              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2836                  do setALRContext ls
2837                     setPendingImplicitTokens [t]
2838                     return (L thisLoc ITvccurly)
2839              (ITin, ALRLayout _ _ : ls, _) ->
2840                  do setALRContext ls
2841                     setNextToken t
2842                     return (L thisLoc ITvccurly)
2843              -- the other ITin case omitted; general case below covers it
2844              (ITcomma, ALRLayout _ _ : ls, _)
2845               | topNoLayoutContainsCommas ls ->
2846                  do setALRContext ls
2847                     setNextToken t
2848                     return (L thisLoc ITvccurly)
2849              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2850                  do setALRContext ls
2851                     setPendingImplicitTokens [t]
2852                     return (L thisLoc ITvccurly)
2853              -- the other ITwhere case omitted; general case below covers it
2854              (_, _, _) -> return t
2855
2856 transitionalAlternativeLayoutWarning :: String -> SDoc
2857 transitionalAlternativeLayoutWarning msg
2858     = text "transitional layout will not be accepted in the future:"
2859    $$ text msg
2860
2861 isALRopen :: Token -> Bool
2862 isALRopen ITcase          = True
2863 isALRopen ITif            = True
2864 isALRopen ITthen          = True
2865 isALRopen IToparen        = True
2866 isALRopen ITobrack        = True
2867 isALRopen ITocurly        = True
2868 -- GHC Extensions:
2869 isALRopen IToubxparen     = True
2870 isALRopen ITparenEscape   = True
2871 isALRopen ITparenTyEscape = True
2872 isALRopen _               = False
2873
2874 isALRclose :: Token -> Bool
2875 isALRclose ITof     = True
2876 isALRclose ITthen   = True
2877 isALRclose ITelse   = True
2878 isALRclose ITcparen = True
2879 isALRclose ITcbrack = True
2880 isALRclose ITccurly = True
2881 -- GHC Extensions:
2882 isALRclose ITcubxparen = True
2883 isALRclose _        = False
2884
2885 isNonDecreasingIndentation :: ALRLayout -> Bool
2886 isNonDecreasingIndentation ALRLayoutDo = True
2887 isNonDecreasingIndentation _           = False
2888
2889 containsCommas :: Token -> Bool
2890 containsCommas IToparen = True
2891 containsCommas ITobrack = True
2892 -- John doesn't have {} as containing commas, but records contain them,
2893 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2894 -- (defaultInstallDirs).
2895 containsCommas ITocurly = True
2896 -- GHC Extensions:
2897 containsCommas IToubxparen = True
2898 containsCommas _        = False
2899
2900 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2901 topNoLayoutContainsCommas [] = False
2902 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2903 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2904
2905 lexToken :: P (RealLocated Token)
2906 lexToken = do
2907   inp@(AI loc1 buf) <- getInput
2908   sc <- getLexState
2909   exts <- getExts
2910   case alexScanUser exts inp sc of
2911     AlexEOF -> do
2912         let span = mkRealSrcSpan loc1 loc1
2913         setLastToken span 0
2914         return (L span ITeof)
2915     AlexError (AI loc2 buf) ->
2916         reportLexError loc1 loc2 buf "lexical error"
2917     AlexSkip inp2 _ -> do
2918         setInput inp2
2919         lexToken
2920     AlexToken inp2@(AI end buf2) _ t -> do
2921         setInput inp2
2922         let span = mkRealSrcSpan loc1 end
2923         let bytes = byteDiff buf buf2
2924         span `seq` setLastToken span bytes
2925         lt <- t span buf bytes
2926         case unRealSrcSpan lt of
2927           ITlineComment _  -> return lt
2928           ITblockComment _ -> return lt
2929           lt' -> do
2930             setLastTk lt'
2931             return lt
2932
2933 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
2934 reportLexError loc1 loc2 buf str
2935   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2936   | otherwise =
2937   let c = fst (nextChar buf)
2938   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2939      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2940      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2941
2942 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
2943 lexTokenStream buf loc dflags = unP go initState{ options = opts' }
2944     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2945           initState@PState{ options = opts } = mkPState dflags' buf loc
2946           opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts }
2947           go = do
2948             ltok <- lexer False return
2949             case ltok of
2950               L _ ITeof -> return []
2951               _ -> liftM (ltok:) go
2952
2953 linePrags = Map.singleton "line" linePrag
2954
2955 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2956                                  ("options_ghc", lex_string_prag IToptions_prag),
2957                                  ("options_haddock", lex_string_prag ITdocOptions),
2958                                  ("language", token ITlanguage_prag),
2959                                  ("include", lex_string_prag ITinclude_prag)])
2960
2961 ignoredPrags = Map.fromList (map ignored pragmas)
2962                where ignored opt = (opt, nested_comment lexToken)
2963                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2964                      options_pragmas = map ("options_" ++) impls
2965                      -- CFILES is a hugs-only thing.
2966                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2967
2968 oneWordPrags = Map.fromList [
2969      ("rules", rulePrag),
2970      ("inline",
2971          strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),
2972      ("inlinable",
2973          strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
2974      ("inlineable",
2975          strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
2976                                     -- Spelling variant
2977      ("notinline",
2978          strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),
2979      ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
2980      ("source", strtoken (\s -> ITsource_prag (SourceText s))),
2981      ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
2982      ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
2983      ("scc", strtoken (\s -> ITscc_prag (SourceText s))),
2984      ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))),
2985      ("core", strtoken (\s -> ITcore_prag (SourceText s))),
2986      ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
2987      ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
2988      ("ann", strtoken (\s -> ITann_prag (SourceText s))),
2989      ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
2990      ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
2991      ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
2992      ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
2993      ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
2994      ("ctype", strtoken (\s -> ITctype (SourceText s))),
2995      ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
2996      ("column", columnPrag)
2997      ]
2998
2999 twoWordPrags = Map.fromList [
3000      ("inline conlike",
3001          strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),
3002      ("notinline conlike",
3003          strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),
3004      ("specialize inline",
3005          strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
3006      ("specialize notinline",
3007          strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
3008      ]
3009
3010 dispatch_pragmas :: Map String Action -> Action
3011 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
3012                                        Just found -> found span buf len
3013                                        Nothing -> lexError "unknown pragma"
3014
3015 known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
3016 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
3017  = isKnown && nextCharIsNot curbuf pragmaNameChar
3018     where l = lexemeToString startbuf (byteDiff startbuf curbuf)
3019           isKnown = isJust $ Map.lookup (clean_pragma l) prags
3020           pragmaNameChar c = isAlphaNum c || c == '_'
3021
3022 clean_pragma :: String -> String
3023 clean_pragma prag = canon_ws (map toLower (unprefix prag))
3024                     where unprefix prag' = case stripPrefix "{-#" prag' of
3025                                              Just rest -> rest
3026                                              Nothing -> prag'
3027                           canonical prag' = case prag' of
3028                                               "noinline" -> "notinline"
3029                                               "specialise" -> "specialize"
3030                                               "constructorlike" -> "conlike"
3031                                               _ -> prag'
3032                           canon_ws s = unwords (map canonical (words s))
3033
3034
3035
3036 {-
3037 %************************************************************************
3038 %*                                                                      *
3039         Helper functions for generating annotations in the parser
3040 %*                                                                      *
3041 %************************************************************************
3042 -}
3043
3044 -- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
3045 --   the AST construct the annotation belongs to; together with the
3046 --   AnnKeywordId, this is the key of the annotation map.
3047 --
3048 --   This type is useful for places in the parser where it is not yet
3049 --   known what SrcSpan an annotation should be added to.  The most
3050 --   common situation is when we are parsing a list: the annotations
3051 --   need to be associated with the AST element that *contains* the
3052 --   list, not the list itself.  'AddAnn' lets us defer adding the
3053 --   annotations until we finish parsing the list and are now parsing
3054 --   the enclosing element; we then apply the 'AddAnn' to associate
3055 --   the annotations.  Another common situation is where a common fragment of
3056 --   the AST has been factored out but there is no separate AST node for
3057 --   this fragment (this occurs in class and data declarations). In this
3058 --   case, the annotation belongs to the parent data declaration.
3059 --
3060 --   The usual way an 'AddAnn' is created is using the 'mj' ("make jump")
3061 --   function, and then it can be discharged using the 'ams' function.
3062 type AddAnn = SrcSpan -> P ()
3063
3064 addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
3065 addAnnotationOnly l a v = P $ \s -> POk s {
3066   annotations = ((l,a), [v]) : annotations s
3067   } ()
3068
3069 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
3070 -- 'AddAnn' values for the opening and closing bordering on the start
3071 -- and end of the span
3072 mkParensApiAnn :: SrcSpan -> [AddAnn]
3073 mkParensApiAnn (UnhelpfulSpan _)  = []
3074 mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
3075   where
3076     mj a l = (\s -> addAnnotation s a l)
3077     f = srcSpanFile ss
3078     sl = srcSpanStartLine ss
3079     sc = srcSpanStartCol ss
3080     el = srcSpanEndLine ss
3081     ec = srcSpanEndCol ss
3082     lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
3083     lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
3084
3085 queueComment :: Located Token -> P()
3086 queueComment c = P $ \s -> POk s {
3087   comment_q = commentToAnnotation c : comment_q s
3088   } ()
3089
3090 -- | Go through the @comment_q@ in @PState@ and remove all comments
3091 -- that belong within the given span
3092 allocateComments :: SrcSpan -> P ()
3093 allocateComments ss = P $ \s ->
3094   let
3095     (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
3096     (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
3097     comment_q' = before ++ after
3098     newAnns = if null middle then []
3099                              else [(ss,middle)]
3100   in
3101     POk s {
3102        comment_q = comment_q'
3103      , annotations_comments = newAnns ++ (annotations_comments s)
3104      } ()
3105
3106 commentToAnnotation :: Located Token -> Located AnnotationComment
3107 commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
3108 commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)
3109 commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
3110 commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)
3111 commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)
3112 commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)
3113 commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)
3114 commentToAnnotation _                           = panic "commentToAnnotation"
3115
3116 -- ---------------------------------------------------------------------
3117
3118 isComment :: Token -> Bool
3119 isComment (ITlineComment     _)   = True
3120 isComment (ITblockComment    _)   = True
3121 isComment _ = False
3122
3123 isDocComment :: Token -> Bool
3124 isDocComment (ITdocCommentNext  _)   = True
3125 isDocComment (ITdocCommentPrev  _)   = True
3126 isDocComment (ITdocCommentNamed _)   = True
3127 isDocComment (ITdocSection      _ _) = True
3128 isDocComment (ITdocOptions      _)   = True
3129 isDocComment _ = False
3130 }