Lexer: turn some fatal errors into non-fatal ones
[ghc.git] / compiler / parser / Lexer.x
1 -----------------------------------------------------------------------------
2 -- (c) The University of Glasgow, 2006
3 --
4 -- GHC's lexer for Haskell 2010 [1].
5 --
6 -- This is a combination of an Alex-generated lexer [2] from a regex
7 -- definition, with some hand-coded bits. [3]
8 --
9 -- Completely accurate information about token-spans within the source
10 -- file is maintained.  Every token has a start and end RealSrcLoc
11 -- attached to it.
12 --
13 -- References:
14 -- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html
15 -- [2] http://www.haskell.org/alex/
16 -- [3] https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/Parser
17 --
18 -----------------------------------------------------------------------------
19
20 --   ToDo / known bugs:
21 --    - parsing integers is a bit slow
22 --    - readRational is a bit slow
23 --
24 --   Known bugs, that were also in the previous version:
25 --    - M... should be 3 tokens, not 1.
26 --    - pragma-end should be only valid in a pragma
27
28 --   qualified operator NOTES.
29 --
30 --   - If M.(+) is a single lexeme, then..
31 --     - Probably (+) should be a single lexeme too, for consistency.
32 --       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.
33 --     - But we have to rule out reserved operators, otherwise (..) becomes
34 --       a different lexeme.
35 --     - Should we therefore also rule out reserved operators in the qualified
36 --       form?  This is quite difficult to achieve.  We don't do it for
37 --       qualified varids.
38
39
40 -- -----------------------------------------------------------------------------
41 -- Alex "Haskell code fragment top"
42
43 {
44 {-# LANGUAGE CPP #-}
45 {-# LANGUAGE BangPatterns #-}
46 {-# LANGUAGE LambdaCase #-}
47
48 {-# OPTIONS_GHC -funbox-strict-fields #-}
49
50 module Lexer (
51    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
52    P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
53    getRealSrcLoc, getPState, withThisPackage,
54    failLocMsgP, srcParseFail,
55    getErrorMessages, getMessages,
56    popContext, pushModuleContext, setLastToken, setSrcLoc,
57    activeContext, nextIsEOF,
58    getLexState, popLexState, pushLexState,
59    ExtBits(..), getBit,
60    addWarning, addError, addFatalError,
61    lexTokenStream,
62    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
63    commentToAnnotation
64   ) where
65
66 import GhcPrelude
67
68 -- base
69 import Control.Monad
70 import Control.Monad.Fail as MonadFail
71 import Data.Bits
72 import Data.Char
73 import Data.List
74 import Data.Maybe
75 import Data.Word
76
77 import EnumSet (EnumSet)
78 import qualified EnumSet
79
80 -- ghc-boot
81 import qualified GHC.LanguageExtensions as LangExt
82
83 -- bytestring
84 import Data.ByteString (ByteString)
85
86 -- containers
87 import Data.Map (Map)
88 import qualified Data.Map as Map
89
90 -- compiler/utils
91 import Bag
92 import Outputable
93 import StringBuffer
94 import FastString
95 import UniqFM
96 import Util             ( readRational, readHexRational )
97
98 -- compiler/main
99 import ErrUtils
100 import DynFlags
101
102 -- compiler/basicTypes
103 import SrcLoc
104 import Module
105 import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..),
106                         IntegralLit(..), FractionalLit(..),
107                         SourceText(..) )
108
109 -- compiler/parser
110 import Ctype
111
112 import ApiAnnotation
113 }
114
115 -- -----------------------------------------------------------------------------
116 -- Alex "Character set macros"
117
118 -- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs
119 -- Any changes here should likely be reflected there.
120 $unispace    = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex].
121 $nl          = [\n\r\f]
122 $whitechar   = [$nl\v\ $unispace]
123 $white_no_nl = $whitechar # \n -- TODO #8424
124 $tab         = \t
125
126 $ascdigit  = 0-9
127 $unidigit  = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex].
128 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
129 $digit     = [$ascdigit $unidigit]
130
131 $special   = [\(\)\,\;\[\]\`\{\}]
132 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
133 $unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex].
134 $symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']
135
136 $unilarge  = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex].
137 $asclarge  = [A-Z]
138 $large     = [$asclarge $unilarge]
139
140 $unismall  = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex].
141 $ascsmall  = [a-z]
142 $small     = [$ascsmall $unismall \_]
143
144 $unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex].
145 $graphic   = [$small $large $symbol $digit $special $unigraphic \"\']
146
147 $binit     = 0-1
148 $octit     = 0-7
149 $hexit     = [$decdigit A-F a-f]
150
151 $uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex].
152 $idchar    = [$small $large $digit $uniidchar \']
153
154 $pragmachar = [$small $large $digit]
155
156 $docsym    = [\| \^ \* \$]
157
158
159 -- -----------------------------------------------------------------------------
160 -- Alex "Regular expression macros"
161
162 @varid     = $small $idchar*          -- variable identifiers
163 @conid     = $large $idchar*          -- constructor identifiers
164
165 @varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol
166 @consym    = \: $symbol*              -- constructor (operator) symbol
167
168 -- See Note [Lexing NumericUnderscores extension] and #14473
169 @numspc       = _*                   -- numeric spacer (#14473)
170 @decimal      = $decdigit(@numspc $decdigit)*
171 @binary       = $binit(@numspc $binit)*
172 @octal        = $octit(@numspc $octit)*
173 @hexadecimal  = $hexit(@numspc $hexit)*
174 @exponent     = @numspc [eE] [\-\+]? @decimal
175 @bin_exponent = @numspc [pP] [\-\+]? @decimal
176
177 @qual = (@conid \.)+
178 @qvarid = @qual @varid
179 @qconid = @qual @conid
180 @qvarsym = @qual @varsym
181 @qconsym = @qual @consym
182
183 @floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent
184 @hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent
185
186 -- normal signed numerical literals can only be explicitly negative,
187 -- not explicitly positive (contrast @exponent)
188 @negative = \-
189 @signed = @negative ?
190
191
192 -- -----------------------------------------------------------------------------
193 -- Alex "Identifier"
194
195 haskell :-
196
197
198 -- -----------------------------------------------------------------------------
199 -- Alex "Rules"
200
201 -- everywhere: skip whitespace
202 $white_no_nl+ ;
203 $tab          { warnTab }
204
205 -- Everywhere: deal with nested comments.  We explicitly rule out
206 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
207 -- (this can happen even though pragmas will normally take precedence due to
208 -- longest-match, because pragmas aren't valid in every state, but comments
209 -- are). We also rule out nested Haddock comments, if the -haddock flag is
210 -- set.
211
212 "{-" / { isNormalComment } { nested_comment lexToken }
213
214 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
215 -- more dashes followed by a symbol should be parsed as a varsym, so we
216 -- have to exclude those.
217
218 -- Since Haddock comments aren't valid in every state, we need to rule them
219 -- out here.
220
221 -- The following two rules match comments that begin with two dashes, but
222 -- continue with a different character. The rules test that this character
223 -- is not a symbol (in which case we'd have a varsym), and that it's not a
224 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
225 -- have a Haddock comment). The rules then munch the rest of the line.
226
227 "-- " ~$docsym .* { lineCommentToken }
228 "--" [^$symbol \ ] .* { lineCommentToken }
229
230 -- Next, match Haddock comments if no -haddock flag
231
232 "-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { lineCommentToken }
233
234 -- Now, when we've matched comments that begin with 2 dashes and continue
235 -- with a different character, we need to match comments that begin with three
236 -- or more dashes (which clearly can't be Haddock comments). We only need to
237 -- make sure that the first non-dash character isn't a symbol, and munch the
238 -- rest of the line.
239
240 "---"\-* ~$symbol .* { lineCommentToken }
241
242 -- Since the previous rules all match dashes followed by at least one
243 -- character, we also need to match a whole line filled with just dashes.
244
245 "--"\-* / { atEOL } { lineCommentToken }
246
247 -- We need this rule since none of the other single line comment rules
248 -- actually match this case.
249
250 "-- " / { atEOL } { lineCommentToken }
251
252 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
253 -- blank lines) until we find a non-whitespace character, then do layout
254 -- processing.
255 --
256 -- One slight wibble here: what if the line begins with {-#? In
257 -- theory, we have to lex the pragma to see if it's one we recognise,
258 -- and if it is, then we backtrack and do_bol, otherwise we treat it
259 -- as a nested comment.  We don't bother with this: if the line begins
260 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
261 <bol> {
262   \n                                    ;
263   ^\# line                              { begin line_prag1 }
264   ^\# / { followedByDigit }             { begin line_prag1 }
265   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
266   ^\# \! .* \n                          ; -- #!, for scripts
267   ()                                    { do_bol }
268 }
269
270 -- after a layout keyword (let, where, do, of), we begin a new layout
271 -- context if the curly brace is missing.
272 -- Careful! This stuff is quite delicate.
273 <layout, layout_do, layout_if> {
274   \{ / { notFollowedBy '-' }            { hopefully_open_brace }
275         -- we might encounter {-# here, but {- has been handled already
276   \n                                    ;
277   ^\# (line)?                           { begin line_prag1 }
278 }
279
280 -- after an 'if', a vertical bar starts a layout context for MultiWayIf
281 <layout_if> {
282   \| / { notFollowedBySymbol }          { new_layout_context True dontGenerateSemic ITvbar }
283   ()                                    { pop }
284 }
285
286 -- do is treated in a subtly different way, see new_layout_context
287 <layout>    ()                          { new_layout_context True  generateSemic ITvocurly }
288 <layout_do> ()                          { new_layout_context False generateSemic ITvocurly }
289
290 -- after a new layout context which was found to be to the left of the
291 -- previous context, we have generated a '{' token, and we now need to
292 -- generate a matching '}' token.
293 <layout_left>  ()                       { do_layout_left }
294
295 <0,option_prags> \n                     { begin bol }
296
297 "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }
298                                 { dispatch_pragmas linePrags }
299
300 -- single-line line pragmas, of the form
301 --    # <line> "<file>" <extra-stuff> \n
302 <line_prag1> {
303   @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag1a }
304   ()                                           { failLinePrag1 }
305 }
306 <line_prag1a> .*                               { popLinePrag1 }
307
308 -- Haskell-style line pragmas, of the form
309 --    {-# LINE <line> "<file>" #-}
310 <line_prag2> {
311   @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag2a }
312 }
313 <line_prag2a> "#-}"|"-}"                       { pop }
314    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
315    -- with older versions of GHC which generated these.
316
317 -- Haskell-style column pragmas, of the form
318 --    {-# COLUMN <column> #-}
319 <column_prag> @decimal $whitechar* "#-}" { setColumn }
320
321 <0,option_prags> {
322   "{-#" $whitechar* $pragmachar+
323         $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }
324                                  { dispatch_pragmas twoWordPrags }
325
326   "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }
327                                  { dispatch_pragmas oneWordPrags }
328
329   -- We ignore all these pragmas, but don't generate a warning for them
330   "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }
331                                  { dispatch_pragmas ignoredPrags }
332
333   -- ToDo: should only be valid inside a pragma:
334   "#-}"                          { endPrag }
335 }
336
337 <option_prags> {
338   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
339                                    { dispatch_pragmas fileHeaderPrags }
340 }
341
342 <0> {
343   -- In the "0" mode we ignore these pragmas
344   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
345                      { nested_comment lexToken }
346 }
347
348 <0,option_prags> {
349   "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
350                     (nested_comment lexToken) }
351 }
352
353 -- '0' state: ordinary lexemes
354
355 -- Haddock comments
356
357 <0,option_prags> {
358   "-- " $docsym      / { ifExtension HaddockBit } { multiline_doc_comment }
359   "{-" \ ? $docsym   / { ifExtension HaddockBit } { nested_doc_comment }
360 }
361
362 -- "special" symbols
363
364 <0> {
365   "[|"        / { ifExtension ThQuotesBit } { token (ITopenExpQuote NoE NormalSyntax) }
366   "[||"       / { ifExtension ThQuotesBit } { token (ITopenTExpQuote NoE) }
367   "[e|"       / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }
368   "[e||"      / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) }
369   "[p|"       / { ifExtension ThQuotesBit } { token ITopenPatQuote }
370   "[d|"       / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote }
371   "[t|"       / { ifExtension ThQuotesBit } { token ITopenTypQuote }
372   "|]"        / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) }
373   "||]"       / { ifExtension ThQuotesBit } { token ITcloseTExpQuote }
374   \$ @varid   / { ifExtension ThBit }       { skip_one_varid ITidEscape }
375   "$$" @varid / { ifExtension ThBit }       { skip_two_varid ITidTyEscape }
376   "$("        / { ifExtension ThBit }       { token ITparenEscape }
377   "$$("       / { ifExtension ThBit }       { token ITparenTyEscape }
378
379   "[" @varid "|"  / { ifExtension QqBit }   { lex_quasiquote_tok }
380
381   -- qualified quasi-quote (#5555)
382   "[" @qvarid "|"  / { ifExtension QqBit }  { lex_qquasiquote_tok }
383
384   $unigraphic -- ⟦
385     / { ifCurrentChar '⟦' `alexAndPred`
386         ifExtension UnicodeSyntaxBit `alexAndPred`
387         ifExtension ThQuotesBit }
388     { token (ITopenExpQuote NoE UnicodeSyntax) }
389   $unigraphic -- ⟧
390     / { ifCurrentChar '⟧' `alexAndPred`
391         ifExtension UnicodeSyntaxBit `alexAndPred`
392         ifExtension ThQuotesBit }
393     { token (ITcloseQuote UnicodeSyntax) }
394 }
395
396   -- See Note [Lexing type applications]
397 <0> {
398     [^ $idchar \) ] ^
399   "@"
400     / { ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol }
401     { token ITtypeApp }
402 }
403
404 <0> {
405   "(|"
406     / { ifExtension ArrowsBit `alexAndPred`
407         notFollowedBySymbol }
408     { special (IToparenbar NormalSyntax) }
409   "|)"
410     / { ifExtension ArrowsBit }
411     { special (ITcparenbar NormalSyntax) }
412
413   $unigraphic -- ⦇
414     / { ifCurrentChar '⦇' `alexAndPred`
415         ifExtension UnicodeSyntaxBit `alexAndPred`
416         ifExtension ArrowsBit }
417     { special (IToparenbar UnicodeSyntax) }
418   $unigraphic -- ⦈
419     / { ifCurrentChar '⦈' `alexAndPred`
420         ifExtension UnicodeSyntaxBit `alexAndPred`
421         ifExtension ArrowsBit }
422     { special (ITcparenbar UnicodeSyntax) }
423 }
424
425 <0> {
426   \? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid }
427 }
428
429 <0> {
430   "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
431 }
432
433 <0> {
434   "(#" / { ifExtension UnboxedTuplesBit `alexOrPred`
435            ifExtension UnboxedSumsBit }
436          { token IToubxparen }
437   "#)" / { ifExtension UnboxedTuplesBit `alexOrPred`
438            ifExtension UnboxedSumsBit }
439          { token ITcubxparen }
440 }
441
442 <0,option_prags> {
443   \(                                    { special IToparen }
444   \)                                    { special ITcparen }
445   \[                                    { special ITobrack }
446   \]                                    { special ITcbrack }
447   \,                                    { special ITcomma }
448   \;                                    { special ITsemi }
449   \`                                    { special ITbackquote }
450
451   \{                                    { open_brace }
452   \}                                    { close_brace }
453 }
454
455 <0,option_prags> {
456   @qvarid                       { idtoken qvarid }
457   @qconid                       { idtoken qconid }
458   @varid                        { varid }
459   @conid                        { idtoken conid }
460 }
461
462 <0> {
463   @qvarid "#"+      / { ifExtension MagicHashBit } { idtoken qvarid }
464   @qconid "#"+      / { ifExtension MagicHashBit } { idtoken qconid }
465   @varid "#"+       / { ifExtension MagicHashBit } { varid }
466   @conid "#"+       / { ifExtension MagicHashBit } { idtoken conid }
467 }
468
469 -- ToDo: - move `var` and (sym) into lexical syntax?
470 --       - remove backquote from $special?
471 <0> {
472   @qvarsym                                         { idtoken qvarsym }
473   @qconsym                                         { idtoken qconsym }
474   @varsym                                          { varsym }
475   @consym                                          { consym }
476 }
477
478 -- For the normal boxed literals we need to be careful
479 -- when trying to be close to Haskell98
480
481 -- Note [Lexing NumericUnderscores extension] (#14473)
482 --
483 -- NumericUnderscores extension allows underscores in numeric literals.
484 -- Multiple underscores are represented with @numspc macro.
485 -- To be simpler, we have only the definitions with underscores.
486 -- And then we have a separate function (tok_integral and tok_frac)
487 -- that validates the literals.
488 -- If extensions are not enabled, check that there are no underscores.
489 --
490 <0> {
491   -- Normal integral literals (:: Num a => a, from Integer)
492   @decimal                                                                   { tok_num positive 0 0 decimal }
493   0[bB] @numspc @binary                / { ifExtension BinaryLiteralsBit }   { tok_num positive 2 2 binary }
494   0[oO] @numspc @octal                                                       { tok_num positive 2 2 octal }
495   0[xX] @numspc @hexadecimal                                                 { tok_num positive 2 2 hexadecimal }
496   @negative @decimal                   / { ifExtension NegativeLiteralsBit } { tok_num negative 1 1 decimal }
497   @negative 0[bB] @numspc @binary      / { ifExtension NegativeLiteralsBit `alexAndPred`
498                                            ifExtension BinaryLiteralsBit }   { tok_num negative 3 3 binary }
499   @negative 0[oO] @numspc @octal       / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 octal }
500   @negative 0[xX] @numspc @hexadecimal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 hexadecimal }
501
502   -- Normal rational literals (:: Fractional a => a, from Rational)
503   @floating_point                                                            { tok_frac 0 tok_float }
504   @negative @floating_point            / { ifExtension NegativeLiteralsBit } { tok_frac 0 tok_float }
505   0[xX] @numspc @hex_floating_point    / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }
506   @negative 0[xX] @numspc @hex_floating_point
507                                        / { ifExtension HexFloatLiteralsBit `alexAndPred`
508                                            ifExtension NegativeLiteralsBit } { tok_frac 0 tok_hex_float }
509 }
510
511 <0> {
512   -- Unboxed ints (:: Int#) and words (:: Word#)
513   -- It's simpler (and faster?) to give separate cases to the negatives,
514   -- especially considering octal/hexadecimal prefixes.
515   @decimal                          \# / { ifExtension MagicHashBit }        { tok_primint positive 0 1 decimal }
516   0[bB] @numspc @binary             \# / { ifExtension MagicHashBit `alexAndPred`
517                                            ifExtension BinaryLiteralsBit }   { tok_primint positive 2 3 binary }
518   0[oO] @numspc @octal              \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 octal }
519   0[xX] @numspc @hexadecimal        \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 hexadecimal }
520   @negative @decimal                \# / { ifExtension MagicHashBit }        { tok_primint negative 1 2 decimal }
521   @negative 0[bB] @numspc @binary   \# / { ifExtension MagicHashBit `alexAndPred`
522                                            ifExtension BinaryLiteralsBit }   { tok_primint negative 3 4 binary }
523   @negative 0[oO] @numspc @octal    \# / { ifExtension MagicHashBit }        { tok_primint negative 3 4 octal }
524   @negative 0[xX] @numspc @hexadecimal \#
525                                        / { ifExtension MagicHashBit }        { tok_primint negative 3 4 hexadecimal }
526
527   @decimal                       \# \# / { ifExtension MagicHashBit }        { tok_primword 0 2 decimal }
528   0[bB] @numspc @binary          \# \# / { ifExtension MagicHashBit `alexAndPred`
529                                            ifExtension BinaryLiteralsBit }   { tok_primword 2 4 binary }
530   0[oO] @numspc @octal           \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 octal }
531   0[xX] @numspc @hexadecimal     \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 hexadecimal }
532
533   -- Unboxed floats and doubles (:: Float#, :: Double#)
534   -- prim_{float,double} work with signed literals
535   @signed @floating_point           \# / { ifExtension MagicHashBit }        { tok_frac 1 tok_primfloat }
536   @signed @floating_point        \# \# / { ifExtension MagicHashBit }        { tok_frac 2 tok_primdouble }
537 }
538
539 -- Strings and chars are lexed by hand-written code.  The reason is
540 -- that even if we recognise the string or char here in the regex
541 -- lexer, we would still have to parse the string afterward in order
542 -- to convert it to a String.
543 <0> {
544   \'                            { lex_char_tok }
545   \"                            { lex_string_tok }
546 }
547
548 -- Note [Lexing type applications]
549 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
550 -- The desired syntax for type applications is to prefix the type application
551 -- with '@', like this:
552 --
553 --   foo @Int @Bool baz bum
554 --
555 -- This, of course, conflicts with as-patterns. The conflict arises because
556 -- expressions and patterns use the same parser, and also because we want
557 -- to allow type patterns within expression patterns.
558 --
559 -- Disambiguation is accomplished by requiring *something* to appear between
560 -- type application and the preceding token. This something must end with
561 -- a character that cannot be the end of the variable bound in an as-pattern.
562 -- Currently (June 2015), this means that the something cannot end with a
563 -- $idchar or a close-paren. (The close-paren is necessary if the as-bound
564 -- identifier is symbolic.)
565 --
566 -- Note that looking for whitespace before the '@' is insufficient, because
567 -- of this pathological case:
568 --
569 --   foo {- hi -}@Int
570 --
571 -- This design is predicated on the fact that as-patterns are generally
572 -- whitespace-free, and also that this whole thing is opt-in, with the
573 -- TypeApplications extension.
574
575 -- -----------------------------------------------------------------------------
576 -- Alex "Haskell code fragment bottom"
577
578 {
579
580 -- -----------------------------------------------------------------------------
581 -- The token type
582
583 data Token
584   = ITas                        -- Haskell keywords
585   | ITcase
586   | ITclass
587   | ITdata
588   | ITdefault
589   | ITderiving
590   | ITdo
591   | ITelse
592   | IThiding
593   | ITforeign
594   | ITif
595   | ITimport
596   | ITin
597   | ITinfix
598   | ITinfixl
599   | ITinfixr
600   | ITinstance
601   | ITlet
602   | ITmodule
603   | ITnewtype
604   | ITof
605   | ITqualified
606   | ITthen
607   | ITtype
608   | ITwhere
609
610   | ITforall            IsUnicodeSyntax -- GHC extension keywords
611   | ITexport
612   | ITlabel
613   | ITdynamic
614   | ITsafe
615   | ITinterruptible
616   | ITunsafe
617   | ITstdcallconv
618   | ITccallconv
619   | ITcapiconv
620   | ITprimcallconv
621   | ITjavascriptcallconv
622   | ITmdo
623   | ITfamily
624   | ITrole
625   | ITgroup
626   | ITby
627   | ITusing
628   | ITpattern
629   | ITstatic
630   | ITstock
631   | ITanyclass
632   | ITvia
633
634   -- Backpack tokens
635   | ITunit
636   | ITsignature
637   | ITdependency
638   | ITrequires
639
640   -- Pragmas, see  note [Pragma source text] in BasicTypes
641   | ITinline_prag       SourceText InlineSpec RuleMatchInfo
642   | ITspec_prag         SourceText                -- SPECIALISE
643   | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)
644   | ITsource_prag       SourceText
645   | ITrules_prag        SourceText
646   | ITwarning_prag      SourceText
647   | ITdeprecated_prag   SourceText
648   | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'
649   | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'
650   | ITscc_prag          SourceText
651   | ITgenerated_prag    SourceText
652   | ITcore_prag         SourceText         -- hdaume: core annotations
653   | ITunpack_prag       SourceText
654   | ITnounpack_prag     SourceText
655   | ITann_prag          SourceText
656   | ITcomplete_prag     SourceText
657   | ITclose_prag
658   | IToptions_prag String
659   | ITinclude_prag String
660   | ITlanguage_prag
661   | ITminimal_prag      SourceText
662   | IToverlappable_prag SourceText  -- instance overlap mode
663   | IToverlapping_prag  SourceText  -- instance overlap mode
664   | IToverlaps_prag     SourceText  -- instance overlap mode
665   | ITincoherent_prag   SourceText  -- instance overlap mode
666   | ITctype             SourceText
667   | ITcomment_line_prag         -- See Note [Nested comment line pragmas]
668
669   | ITdotdot                    -- reserved symbols
670   | ITcolon
671   | ITdcolon            IsUnicodeSyntax
672   | ITequal
673   | ITlam
674   | ITlcase
675   | ITvbar
676   | ITlarrow            IsUnicodeSyntax
677   | ITrarrow            IsUnicodeSyntax
678   | ITat
679   | ITtilde
680   | ITdarrow            IsUnicodeSyntax
681   | ITminus
682   | ITbang
683   | ITstar              IsUnicodeSyntax
684   | ITdot
685
686   | ITbiglam                    -- GHC-extension symbols
687
688   | ITocurly                    -- special symbols
689   | ITccurly
690   | ITvocurly
691   | ITvccurly
692   | ITobrack
693   | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays
694   | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays
695   | ITcbrack
696   | IToparen
697   | ITcparen
698   | IToubxparen
699   | ITcubxparen
700   | ITsemi
701   | ITcomma
702   | ITunderscore
703   | ITbackquote
704   | ITsimpleQuote               --  '
705
706   | ITvarid   FastString        -- identifiers
707   | ITconid   FastString
708   | ITvarsym  FastString
709   | ITconsym  FastString
710   | ITqvarid  (FastString,FastString)
711   | ITqconid  (FastString,FastString)
712   | ITqvarsym (FastString,FastString)
713   | ITqconsym (FastString,FastString)
714
715   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
716   | ITlabelvarid   FastString   -- Overloaded label: #x
717
718   | ITchar     SourceText Char       -- Note [Literal source text] in BasicTypes
719   | ITstring   SourceText FastString -- Note [Literal source text] in BasicTypes
720   | ITinteger  IntegralLit           -- Note [Literal source text] in BasicTypes
721   | ITrational FractionalLit
722
723   | ITprimchar   SourceText Char     -- Note [Literal source text] in BasicTypes
724   | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes
725   | ITprimint    SourceText Integer  -- Note [Literal source text] in BasicTypes
726   | ITprimword   SourceText Integer  -- Note [Literal source text] in BasicTypes
727   | ITprimfloat  FractionalLit
728   | ITprimdouble FractionalLit
729
730   -- Template Haskell extension tokens
731   | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|
732   | ITopenPatQuote                      --  [p|
733   | ITopenDecQuote                      --  [d|
734   | ITopenTypQuote                      --  [t|
735   | ITcloseQuote IsUnicodeSyntax        --  |]
736   | ITopenTExpQuote HasE                --  [|| or [e||
737   | ITcloseTExpQuote                    --  ||]
738   | ITidEscape   FastString             --  $x
739   | ITparenEscape                       --  $(
740   | ITidTyEscape   FastString           --  $$x
741   | ITparenTyEscape                     --  $$(
742   | ITtyQuote                           --  ''
743   | ITquasiQuote (FastString,FastString,RealSrcSpan)
744     -- ITquasiQuote(quoter, quote, loc)
745     -- represents a quasi-quote of the form
746     -- [quoter| quote |]
747   | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan)
748     -- ITqQuasiQuote(Qual, quoter, quote, loc)
749     -- represents a qualified quasi-quote of the form
750     -- [Qual.quoter| quote |]
751
752   -- Arrow notation extension
753   | ITproc
754   | ITrec
755   | IToparenbar  IsUnicodeSyntax -- ^ @(|@
756   | ITcparenbar  IsUnicodeSyntax -- ^ @|)@
757   | ITlarrowtail IsUnicodeSyntax -- ^ @-<@
758   | ITrarrowtail IsUnicodeSyntax -- ^ @>-@
759   | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@
760   | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@
761
762   -- | Type application '@' (lexed differently than as-pattern '@',
763   -- due to checking for preceding whitespace)
764   | ITtypeApp
765
766
767   | ITunknown String             -- ^ Used when the lexer can't make sense of it
768   | ITeof                        -- ^ end of file token
769
770   -- Documentation annotations
771   | ITdocCommentNext  String     -- ^ something beginning @-- |@
772   | ITdocCommentPrev  String     -- ^ something beginning @-- ^@
773   | ITdocCommentNamed String     -- ^ something beginning @-- $@
774   | ITdocSection      Int String -- ^ a section heading
775   | ITdocOptions      String     -- ^ doc options (prune, ignore-exports, etc)
776   | ITlineComment     String     -- ^ comment starting by "--"
777   | ITblockComment    String     -- ^ comment in {- -}
778
779   deriving Show
780
781 instance Outputable Token where
782   ppr x = text (show x)
783
784
785 -- the bitmap provided as the third component indicates whether the
786 -- corresponding extension keyword is valid under the extension options
787 -- provided to the compiler; if the extension corresponding to *any* of the
788 -- bits set in the bitmap is enabled, the keyword is valid (this setup
789 -- facilitates using a keyword in two different extensions that can be
790 -- activated independently)
791 --
792 reservedWordsFM :: UniqFM (Token, ExtsBitmap)
793 reservedWordsFM = listToUFM $
794     map (\(x, y, z) -> (mkFastString x, (y, z)))
795         [( "_",              ITunderscore,    0 ),
796          ( "as",             ITas,            0 ),
797          ( "case",           ITcase,          0 ),
798          ( "class",          ITclass,         0 ),
799          ( "data",           ITdata,          0 ),
800          ( "default",        ITdefault,       0 ),
801          ( "deriving",       ITderiving,      0 ),
802          ( "do",             ITdo,            0 ),
803          ( "else",           ITelse,          0 ),
804          ( "hiding",         IThiding,        0 ),
805          ( "if",             ITif,            0 ),
806          ( "import",         ITimport,        0 ),
807          ( "in",             ITin,            0 ),
808          ( "infix",          ITinfix,         0 ),
809          ( "infixl",         ITinfixl,        0 ),
810          ( "infixr",         ITinfixr,        0 ),
811          ( "instance",       ITinstance,      0 ),
812          ( "let",            ITlet,           0 ),
813          ( "module",         ITmodule,        0 ),
814          ( "newtype",        ITnewtype,       0 ),
815          ( "of",             ITof,            0 ),
816          ( "qualified",      ITqualified,     0 ),
817          ( "then",           ITthen,          0 ),
818          ( "type",           ITtype,          0 ),
819          ( "where",          ITwhere,         0 ),
820
821          ( "forall",         ITforall NormalSyntax, 0),
822          ( "mdo",            ITmdo,           xbit RecursiveDoBit),
823              -- See Note [Lexing type pseudo-keywords]
824          ( "family",         ITfamily,        0 ),
825          ( "role",           ITrole,          0 ),
826          ( "pattern",        ITpattern,       xbit PatternSynonymsBit),
827          ( "static",         ITstatic,        xbit StaticPointersBit ),
828          ( "stock",          ITstock,         0 ),
829          ( "anyclass",       ITanyclass,      0 ),
830          ( "via",            ITvia,           0 ),
831          ( "group",          ITgroup,         xbit TransformComprehensionsBit),
832          ( "by",             ITby,            xbit TransformComprehensionsBit),
833          ( "using",          ITusing,         xbit TransformComprehensionsBit),
834
835          ( "foreign",        ITforeign,       xbit FfiBit),
836          ( "export",         ITexport,        xbit FfiBit),
837          ( "label",          ITlabel,         xbit FfiBit),
838          ( "dynamic",        ITdynamic,       xbit FfiBit),
839          ( "safe",           ITsafe,          xbit FfiBit .|.
840                                               xbit SafeHaskellBit),
841          ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),
842          ( "unsafe",         ITunsafe,        xbit FfiBit),
843          ( "stdcall",        ITstdcallconv,   xbit FfiBit),
844          ( "ccall",          ITccallconv,     xbit FfiBit),
845          ( "capi",           ITcapiconv,      xbit CApiFfiBit),
846          ( "prim",           ITprimcallconv,  xbit FfiBit),
847          ( "javascript",     ITjavascriptcallconv, xbit FfiBit),
848
849          ( "unit",           ITunit,          0 ),
850          ( "dependency",     ITdependency,       0 ),
851          ( "signature",      ITsignature,     0 ),
852
853          ( "rec",            ITrec,           xbit ArrowsBit .|.
854                                               xbit RecursiveDoBit),
855          ( "proc",           ITproc,          xbit ArrowsBit)
856      ]
857
858 {-----------------------------------
859 Note [Lexing type pseudo-keywords]
860 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
861
862 One might think that we wish to treat 'family' and 'role' as regular old
863 varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.
864 But, there is no need to do so. These pseudo-keywords are not stolen syntax:
865 they are only used after the keyword 'type' at the top-level, where varids are
866 not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that
867 type families and role annotations are never declared without their extensions
868 on. In fact, by unconditionally lexing these pseudo-keywords as special, we
869 can get better error messages.
870
871 Also, note that these are included in the `varid` production in the parser --
872 a key detail to make all this work.
873 -------------------------------------}
874
875 reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap)
876 reservedSymsFM = listToUFM $
877     map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))
878       [ ("..",  ITdotdot,                   NormalSyntax,  0 )
879         -- (:) is a reserved op, meaning only list cons
880        ,(":",   ITcolon,                    NormalSyntax,  0 )
881        ,("::",  ITdcolon NormalSyntax,      NormalSyntax,  0 )
882        ,("=",   ITequal,                    NormalSyntax,  0 )
883        ,("\\",  ITlam,                      NormalSyntax,  0 )
884        ,("|",   ITvbar,                     NormalSyntax,  0 )
885        ,("<-",  ITlarrow NormalSyntax,      NormalSyntax,  0 )
886        ,("->",  ITrarrow NormalSyntax,      NormalSyntax,  0 )
887        ,("@",   ITat,                       NormalSyntax,  0 )
888        ,("~",   ITtilde,                    NormalSyntax,  0 )
889        ,("=>",  ITdarrow NormalSyntax,      NormalSyntax,  0 )
890        ,("-",   ITminus,                    NormalSyntax,  0 )
891        ,("!",   ITbang,                     NormalSyntax,  0 )
892
893        ,("*",   ITstar NormalSyntax,        NormalSyntax,  xbit StarIsTypeBit)
894
895         -- For 'forall a . t'
896        ,(".",   ITdot,                      NormalSyntax,  0 )
897
898        ,("-<",  ITlarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
899        ,(">-",  ITrarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
900        ,("-<<", ITLarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
901        ,(">>-", ITRarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
902
903        ,("∷",   ITdcolon UnicodeSyntax,     UnicodeSyntax, 0 )
904        ,("⇒",   ITdarrow UnicodeSyntax,     UnicodeSyntax, 0 )
905        ,("∀",   ITforall UnicodeSyntax,     UnicodeSyntax, 0 )
906        ,("→",   ITrarrow UnicodeSyntax,     UnicodeSyntax, 0 )
907        ,("←",   ITlarrow UnicodeSyntax,     UnicodeSyntax, 0 )
908
909        ,("⤙",   ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
910        ,("⤚",   ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
911        ,("⤛",   ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
912        ,("⤜",   ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
913
914        ,("★",   ITstar UnicodeSyntax,       UnicodeSyntax, xbit StarIsTypeBit)
915
916         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
917         -- form part of a large operator.  This would let us have a better
918         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
919        ]
920
921 -- -----------------------------------------------------------------------------
922 -- Lexer actions
923
924 type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
925
926 special :: Token -> Action
927 special tok span _buf _len = return (L span tok)
928
929 token, layout_token :: Token -> Action
930 token t span _buf _len = return (L span t)
931 layout_token t span _buf _len = pushLexState layout >> return (L span t)
932
933 idtoken :: (StringBuffer -> Int -> Token) -> Action
934 idtoken f span buf len = return (L span $! (f buf len))
935
936 skip_one_varid :: (FastString -> Token) -> Action
937 skip_one_varid f span buf len
938   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
939
940 skip_two_varid :: (FastString -> Token) -> Action
941 skip_two_varid f span buf len
942   = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))
943
944 strtoken :: (String -> Token) -> Action
945 strtoken f span buf len =
946   return (L span $! (f $! lexemeToString buf len))
947
948 begin :: Int -> Action
949 begin code _span _str _len = do pushLexState code; lexToken
950
951 pop :: Action
952 pop _span _buf _len = do _ <- popLexState
953                          lexToken
954 -- See Note [Nested comment line pragmas]
955 failLinePrag1 :: Action
956 failLinePrag1 span _buf _len = do
957   b <- getBit InNestedCommentBit
958   if b then return (L span ITcomment_line_prag)
959        else lexError "lexical error in pragma"
960
961 -- See Note [Nested comment line pragmas]
962 popLinePrag1 :: Action
963 popLinePrag1 span _buf _len = do
964   b <- getBit InNestedCommentBit
965   if b then return (L span ITcomment_line_prag) else do
966     _ <- popLexState
967     lexToken
968
969 hopefully_open_brace :: Action
970 hopefully_open_brace span buf len
971  = do relaxed <- getBit RelaxedLayoutBit
972       ctx <- getContext
973       (AI l _) <- getInput
974       let offset = srcLocCol l
975           isOK = relaxed ||
976                  case ctx of
977                  Layout prev_off _ : _ -> prev_off < offset
978                  _                     -> True
979       if isOK then pop_and open_brace span buf len
980               else addFatalError (RealSrcSpan span) (text "Missing block")
981
982 pop_and :: Action -> Action
983 pop_and act span buf len = do _ <- popLexState
984                               act span buf len
985
986 {-# INLINE nextCharIs #-}
987 nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
988 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
989
990 {-# INLINE nextCharIsNot #-}
991 nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool
992 nextCharIsNot buf p = not (nextCharIs buf p)
993
994 notFollowedBy :: Char -> AlexAccPred ExtsBitmap
995 notFollowedBy char _ _ _ (AI _ buf)
996   = nextCharIsNot buf (== char)
997
998 notFollowedBySymbol :: AlexAccPred ExtsBitmap
999 notFollowedBySymbol _ _ _ (AI _ buf)
1000   = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")
1001
1002 followedByDigit :: AlexAccPred ExtsBitmap
1003 followedByDigit _ _ _ (AI _ buf)
1004   = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))
1005
1006 ifCurrentChar :: Char -> AlexAccPred ExtsBitmap
1007 ifCurrentChar char _ (AI _ buf) _ _
1008   = nextCharIs buf (== char)
1009
1010 -- We must reject doc comments as being ordinary comments everywhere.
1011 -- In some cases the doc comment will be selected as the lexeme due to
1012 -- maximal munch, but not always, because the nested comment rule is
1013 -- valid in all states, but the doc-comment rules are only valid in
1014 -- the non-layout states.
1015 isNormalComment :: AlexAccPred ExtsBitmap
1016 isNormalComment bits _ _ (AI _ buf)
1017   | HaddockBit `xtest` bits = notFollowedByDocOrPragma
1018   | otherwise               = nextCharIsNot buf (== '#')
1019   where
1020     notFollowedByDocOrPragma
1021        = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))
1022
1023 afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool
1024 afterOptionalSpace buf p
1025     = if nextCharIs buf (== ' ')
1026       then p (snd (nextChar buf))
1027       else p buf
1028
1029 atEOL :: AlexAccPred ExtsBitmap
1030 atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
1031
1032 ifExtension :: ExtBits -> AlexAccPred ExtsBitmap
1033 ifExtension extBits bits _ _ _ = extBits `xtest` bits
1034
1035 alexNotPred p userState in1 len in2
1036   = not (p userState in1 len in2)
1037
1038 alexOrPred p1 p2 userState in1 len in2
1039   = p1 userState in1 len in2 || p2 userState in1 len in2
1040
1041 multiline_doc_comment :: Action
1042 multiline_doc_comment span buf _len = withLexedDocType (worker "")
1043   where
1044     worker commentAcc input docType checkNextLine = case alexGetChar' input of
1045       Just ('\n', input')
1046         | checkNextLine -> case checkIfCommentLine input' of
1047           Just input -> worker ('\n':commentAcc) input docType checkNextLine
1048           Nothing -> docCommentEnd input commentAcc docType buf span
1049         | otherwise -> docCommentEnd input commentAcc docType buf span
1050       Just (c, input) -> worker (c:commentAcc) input docType checkNextLine
1051       Nothing -> docCommentEnd input commentAcc docType buf span
1052
1053     -- Check if the next line of input belongs to this doc comment as well.
1054     -- A doc comment continues onto the next line when the following
1055     -- conditions are met:
1056     --   * The line starts with "--"
1057     --   * The line doesn't start with "---".
1058     --   * The line doesn't start with "-- $", because that would be the
1059     --     start of a /new/ named haddock chunk (#10398).
1060     checkIfCommentLine :: AlexInput -> Maybe AlexInput
1061     checkIfCommentLine input = check (dropNonNewlineSpace input)
1062       where
1063         check input = do
1064           ('-', input) <- alexGetChar' input
1065           ('-', input) <- alexGetChar' input
1066           (c, after_c) <- alexGetChar' input
1067           case c of
1068             '-' -> Nothing
1069             ' ' -> case alexGetChar' after_c of
1070                      Just ('$', _) -> Nothing
1071                      _ -> Just input
1072             _   -> Just input
1073
1074         dropNonNewlineSpace input = case alexGetChar' input of
1075           Just (c, input')
1076             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
1077             | otherwise -> input
1078           Nothing -> input
1079
1080 lineCommentToken :: Action
1081 lineCommentToken span buf len = do
1082   b <- getBit RawTokenStreamBit
1083   if b then strtoken ITlineComment span buf len else lexToken
1084
1085 {-
1086   nested comments require traversing by hand, they can't be parsed
1087   using regular expressions.
1088 -}
1089 nested_comment :: P (RealLocated Token) -> Action
1090 nested_comment cont span buf len = do
1091   input <- getInput
1092   go (reverse $ lexemeToString buf len) (1::Int) input
1093   where
1094     go commentAcc 0 input = do
1095       setInput input
1096       b <- getBit RawTokenStreamBit
1097       if b
1098         then docCommentEnd input commentAcc ITblockComment buf span
1099         else cont
1100     go commentAcc n input = case alexGetChar' input of
1101       Nothing -> errBrace input span
1102       Just ('-',input) -> case alexGetChar' input of
1103         Nothing  -> errBrace input span
1104         Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'
1105         Just (_,_)          -> go ('-':commentAcc) n input
1106       Just ('\123',input) -> case alexGetChar' input of  -- '{' char
1107         Nothing  -> errBrace input span
1108         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
1109         Just (_,_)       -> go ('\123':commentAcc) n input
1110       -- See Note [Nested comment line pragmas]
1111       Just ('\n',input) -> case alexGetChar' input of
1112         Nothing  -> errBrace input span
1113         Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
1114                            go (parsedAcc ++ '\n':commentAcc) n input
1115         Just (_,_)   -> go ('\n':commentAcc) n input
1116       Just (c,input) -> go (c:commentAcc) n input
1117
1118 nested_doc_comment :: Action
1119 nested_doc_comment span buf _len = withLexedDocType (go "")
1120   where
1121     go commentAcc input docType _ = case alexGetChar' input of
1122       Nothing -> errBrace input span
1123       Just ('-',input) -> case alexGetChar' input of
1124         Nothing -> errBrace input span
1125         Just ('\125',input) ->
1126           docCommentEnd input commentAcc docType buf span
1127         Just (_,_) -> go ('-':commentAcc) input docType False
1128       Just ('\123', input) -> case alexGetChar' input of
1129         Nothing  -> errBrace input span
1130         Just ('-',input) -> do
1131           setInput input
1132           let cont = do input <- getInput; go commentAcc input docType False
1133           nested_comment cont span buf _len
1134         Just (_,_) -> go ('\123':commentAcc) input docType False
1135       -- See Note [Nested comment line pragmas]
1136       Just ('\n',input) -> case alexGetChar' input of
1137         Nothing  -> errBrace input span
1138         Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
1139                            go (parsedAcc ++ '\n':commentAcc) input docType False
1140         Just (_,_)   -> go ('\n':commentAcc) input docType False
1141       Just (c,input) -> go (c:commentAcc) input docType False
1142
1143 -- See Note [Nested comment line pragmas]
1144 parseNestedPragma :: AlexInput -> P (String,AlexInput)
1145 parseNestedPragma input@(AI _ buf) = do
1146   origInput <- getInput
1147   setInput input
1148   setExts (.|. xbit InNestedCommentBit)
1149   pushLexState bol
1150   lt <- lexToken
1151   _ <- popLexState
1152   setExts (.&. complement (xbit InNestedCommentBit))
1153   postInput@(AI _ postBuf) <- getInput
1154   setInput origInput
1155   case unRealSrcSpan lt of
1156     ITcomment_line_prag -> do
1157       let bytes = byteDiff buf postBuf
1158           diff  = lexemeToString buf bytes
1159       return (reverse diff, postInput)
1160     lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))
1161
1162 {-
1163 Note [Nested comment line pragmas]
1164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1165 We used to ignore cpp-preprocessor-generated #line pragmas if they were inside
1166 nested comments.
1167
1168 Now, when parsing a nested comment, if we encounter a line starting with '#' we
1169 call parseNestedPragma, which executes the following:
1170 1. Save the current lexer input (loc, buf) for later
1171 2. Set the current lexer input to the beginning of the line starting with '#'
1172 3. Turn the 'InNestedComment' extension on
1173 4. Push the 'bol' lexer state
1174 5. Lex a token. Due to (2), (3), and (4), this should always lex a single line
1175    or less and return the ITcomment_line_prag token. This may set source line
1176    and file location if a #line pragma is successfully parsed
1177 6. Restore lexer input and state to what they were before we did all this
1178 7. Return control to the function parsing a nested comment, informing it of
1179    what the lexer parsed
1180
1181 Regarding (5) above:
1182 Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)
1183 checks if the 'InNestedComment' extension is set. If it is, that function will
1184 return control to parseNestedPragma by returning the ITcomment_line_prag token.
1185
1186 See #314 for more background on the bug this fixes.
1187 -}
1188
1189 withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
1190                  -> P (RealLocated Token)
1191 withLexedDocType lexDocComment = do
1192   input@(AI _ buf) <- getInput
1193   case prevChar buf ' ' of
1194     -- The `Bool` argument to lexDocComment signals whether or not the next
1195     -- line of input might also belong to this doc comment.
1196     '|' -> lexDocComment input ITdocCommentNext True
1197     '^' -> lexDocComment input ITdocCommentPrev True
1198     '$' -> lexDocComment input ITdocCommentNamed True
1199     '*' -> lexDocSection 1 input
1200     _ -> panic "withLexedDocType: Bad doc type"
1201  where
1202     lexDocSection n input = case alexGetChar' input of
1203       Just ('*', input) -> lexDocSection (n+1) input
1204       Just (_,   _)     -> lexDocComment input (ITdocSection n) False
1205       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
1206
1207 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
1208 -- off again at the end of the pragma.
1209 rulePrag :: Action
1210 rulePrag span buf len = do
1211   setExts (.|. xbit InRulePragBit)
1212   let !src = lexemeToString buf len
1213   return (L span (ITrules_prag (SourceText src)))
1214
1215 -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
1216 -- of updating the position in 'PState'
1217 linePrag :: Action
1218 linePrag span buf len = do
1219   usePosPrags <- getBit UsePosPragsBit
1220   if usePosPrags
1221     then begin line_prag2 span buf len
1222     else let !src = lexemeToString buf len
1223          in return (L span (ITline_prag (SourceText src)))
1224
1225 -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
1226 -- of updating the position in 'PState'
1227 columnPrag :: Action
1228 columnPrag span buf len = do
1229   usePosPrags <- getBit UsePosPragsBit
1230   let !src = lexemeToString buf len
1231   if usePosPrags
1232     then begin column_prag span buf len
1233     else let !src = lexemeToString buf len
1234          in return (L span (ITcolumn_prag (SourceText src)))
1235
1236 endPrag :: Action
1237 endPrag span _buf _len = do
1238   setExts (.&. complement (xbit InRulePragBit))
1239   return (L span ITclose_prag)
1240
1241 -- docCommentEnd
1242 -------------------------------------------------------------------------------
1243 -- This function is quite tricky. We can't just return a new token, we also
1244 -- need to update the state of the parser. Why? Because the token is longer
1245 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
1246 -- it writes the wrong token length to the parser state. This function is
1247 -- called afterwards, so it can just update the state.
1248
1249 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
1250                  RealSrcSpan -> P (RealLocated Token)
1251 docCommentEnd input commentAcc docType buf span = do
1252   setInput input
1253   let (AI loc nextBuf) = input
1254       comment = reverse commentAcc
1255       span' = mkRealSrcSpan (realSrcSpanStart span) loc
1256       last_len = byteDiff buf nextBuf
1257
1258   span `seq` setLastToken span' last_len
1259   return (L span' (docType comment))
1260
1261 errBrace :: AlexInput -> RealSrcSpan -> P a
1262 errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
1263
1264 open_brace, close_brace :: Action
1265 open_brace span _str _len = do
1266   ctx <- getContext
1267   setContext (NoLayout:ctx)
1268   return (L span ITocurly)
1269 close_brace span _str _len = do
1270   popContext
1271   return (L span ITccurly)
1272
1273 qvarid, qconid :: StringBuffer -> Int -> Token
1274 qvarid buf len = ITqvarid $! splitQualName buf len False
1275 qconid buf len = ITqconid $! splitQualName buf len False
1276
1277 splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)
1278 -- takes a StringBuffer and a length, and returns the module name
1279 -- and identifier parts of a qualified name.  Splits at the *last* dot,
1280 -- because of hierarchical module names.
1281 splitQualName orig_buf len parens = split orig_buf orig_buf
1282   where
1283     split buf dot_buf
1284         | orig_buf `byteDiff` buf >= len  = done dot_buf
1285         | c == '.'                        = found_dot buf'
1286         | otherwise                       = split buf' dot_buf
1287       where
1288        (c,buf') = nextChar buf
1289
1290     -- careful, we might get names like M....
1291     -- so, if the character after the dot is not upper-case, this is
1292     -- the end of the qualifier part.
1293     found_dot buf -- buf points after the '.'
1294         | isUpper c    = split buf' buf
1295         | otherwise    = done buf
1296       where
1297        (c,buf') = nextChar buf
1298
1299     done dot_buf =
1300         (lexemeToFastString orig_buf (qual_size - 1),
1301          if parens -- Prelude.(+)
1302             then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)
1303             else lexemeToFastString dot_buf (len - qual_size))
1304       where
1305         qual_size = orig_buf `byteDiff` dot_buf
1306
1307 varid :: Action
1308 varid span buf len =
1309   case lookupUFM reservedWordsFM fs of
1310     Just (ITcase, _) -> do
1311       lastTk <- getLastTk
1312       keyword <- case lastTk of
1313         Just ITlam -> do
1314           lambdaCase <- getBit LambdaCaseBit
1315           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 Trac #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 -- | Check if a given flag is currently set in the bitmap.
2280 getBit :: ExtBits -> P Bool
2281 getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
2282                        in b `seq` POk s b
2283
2284 xbit :: ExtBits -> ExtsBitmap
2285 xbit = bit . fromEnum
2286
2287 xtest :: ExtBits -> ExtsBitmap -> Bool
2288 xtest ext xmap = testBit xmap (fromEnum ext)
2289
2290 -- | Various boolean flags, mostly language extensions, that impact lexing and
2291 -- parsing. Note that a handful of these can change during lexing/parsing.
2292 data ExtBits
2293   -- Flags that are constant once parsing starts
2294   = FfiBit
2295   | InterruptibleFfiBit
2296   | CApiFfiBit
2297   | ArrowsBit
2298   | ThBit
2299   | ThQuotesBit
2300   | IpBit
2301   | OverloadedLabelsBit -- #x overloaded labels
2302   | ExplicitForallBit -- the 'forall' keyword
2303   | BangPatBit -- Tells the parser to understand bang-patterns
2304                -- (doesn't affect the lexer)
2305   | PatternSynonymsBit -- pattern synonyms
2306   | HaddockBit-- Lex and parse Haddock comments
2307   | MagicHashBit -- "#" in both functions and operators
2308   | RecursiveDoBit -- mdo
2309   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
2310   | UnboxedTuplesBit -- (# and #)
2311   | UnboxedSumsBit -- (# and #)
2312   | DatatypeContextsBit
2313   | MonadComprehensionsBit
2314   | TransformComprehensionsBit
2315   | QqBit -- enable quasiquoting
2316   | RawTokenStreamBit -- producing a token stream with all comments included
2317   | AlternativeLayoutRuleBit
2318   | ALRTransitionalBit
2319   | RelaxedLayoutBit
2320   | NondecreasingIndentationBit
2321   | SafeHaskellBit
2322   | TraditionalRecordSyntaxBit
2323   | ExplicitNamespacesBit
2324   | LambdaCaseBit
2325   | BinaryLiteralsBit
2326   | NegativeLiteralsBit
2327   | HexFloatLiteralsBit
2328   | TypeApplicationsBit
2329   | StaticPointersBit
2330   | NumericUnderscoresBit
2331   | StarIsTypeBit
2332   | BlockArgumentsBit
2333   | NPlusKPatternsBit
2334   | DoAndIfThenElseBit
2335   | MultiWayIfBit
2336   | GadtSyntaxBit
2337
2338   -- Flags that are updated once parsing starts
2339   | InRulePragBit
2340   | InNestedCommentBit -- See Note [Nested comment line pragmas]
2341   | UsePosPragsBit
2342     -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'
2343     -- update the internal position. Otherwise, those pragmas are lexed as
2344     -- tokens of their own.
2345   deriving Enum
2346
2347
2348
2349
2350
2351 -- PState for parsing options pragmas
2352 --
2353 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2354 pragState dynflags buf loc = (mkPState dynflags buf loc) {
2355                                  lex_state = [bol, option_prags, 0]
2356                              }
2357
2358 {-# INLINE mkParserFlags' #-}
2359 mkParserFlags'
2360   :: EnumSet WarningFlag        -- ^ warnings flags enabled
2361   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
2362   -> UnitId                     -- ^ key of package currently being compiled
2363   -> Bool                       -- ^ are safe imports on?
2364   -> Bool                       -- ^ keeping Haddock comment tokens
2365   -> Bool                       -- ^ keep regular comment tokens
2366
2367   -> Bool
2368   -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update
2369   -- the internal position kept by the parser. Otherwise, those pragmas are
2370   -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.
2371
2372   -> ParserFlags
2373 -- ^ Given exactly the information needed, set up the 'ParserFlags'
2374 mkParserFlags' warningFlags extensionFlags thisPackage
2375   safeImports isHaddock rawTokStream usePosPrags =
2376     ParserFlags {
2377       pWarningFlags = warningFlags
2378     , pThisPackage = thisPackage
2379     , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
2380     }
2381   where
2382     safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
2383     langExtBits =
2384           FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface
2385       .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI
2386       .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI
2387       .|. ArrowsBit                   `xoptBit` LangExt.Arrows
2388       .|. ThBit                       `xoptBit` LangExt.TemplateHaskell
2389       .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes
2390       .|. QqBit                       `xoptBit` LangExt.QuasiQuotes
2391       .|. IpBit                       `xoptBit` LangExt.ImplicitParams
2392       .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels
2393       .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll
2394       .|. BangPatBit                  `xoptBit` LangExt.BangPatterns
2395       .|. MagicHashBit                `xoptBit` LangExt.MagicHash
2396       .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo
2397       .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax
2398       .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples
2399       .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums
2400       .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts
2401       .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp
2402       .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions
2403       .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule
2404       .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional
2405       .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout
2406       .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation
2407       .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax
2408       .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces
2409       .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase
2410       .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals
2411       .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals
2412       .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals
2413       .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms
2414       .|. TypeApplicationsBit         `xoptBit` LangExt.TypeApplications
2415       .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers
2416       .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores
2417       .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType
2418       .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments
2419       .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns
2420       .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse
2421       .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf
2422       .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax
2423     optBits =
2424           HaddockBit        `setBitIf` isHaddock
2425       .|. RawTokenStreamBit `setBitIf` rawTokStream
2426       .|. UsePosPragsBit    `setBitIf` usePosPrags
2427
2428     xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
2429
2430     setBitIf :: ExtBits -> Bool -> ExtsBitmap
2431     b `setBitIf` cond | cond      = xbit b
2432                       | otherwise = 0
2433
2434 -- | Extracts the flag information needed for parsing
2435 mkParserFlags :: DynFlags -> ParserFlags
2436 mkParserFlags =
2437   mkParserFlags'
2438     <$> DynFlags.warningFlags
2439     <*> DynFlags.extensionFlags
2440     <*> DynFlags.thisPackage
2441     <*> safeImportsOn
2442     <*> gopt Opt_Haddock
2443     <*> gopt Opt_KeepRawTokenStream
2444     <*> const True
2445
2446 -- | Creates a parse state from a 'DynFlags' value
2447 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2448 mkPState flags = mkPStatePure (mkParserFlags flags)
2449
2450 -- | Creates a parse state from a 'ParserFlags' value
2451 mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
2452 mkPStatePure options buf loc =
2453   PState {
2454       buffer        = buf,
2455       options       = options,
2456       messages      = const emptyMessages,
2457       tab_first     = Nothing,
2458       tab_count     = 0,
2459       last_tk       = Nothing,
2460       last_loc      = mkRealSrcSpan loc loc,
2461       last_len      = 0,
2462       loc           = loc,
2463       context       = [],
2464       lex_state     = [bol, 0],
2465       srcfiles      = [],
2466       alr_pending_implicit_tokens = [],
2467       alr_next_token = Nothing,
2468       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
2469       alr_context = [],
2470       alr_expecting_ocurly = Nothing,
2471       alr_justClosedExplicitLetBlock = False,
2472       annotations = [],
2473       comment_q = [],
2474       annotations_comments = []
2475     }
2476
2477 -- | Add a non-fatal error. Use this when the parser can produce a result
2478 --   despite the error.
2479 --
2480 --   For example, when GHC encounters a @forall@ in a type,
2481 --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
2482 --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
2483 --   the accumulator.
2484 --
2485 --   Control flow wise, non-fatal errors act like warnings: they are added
2486 --   to the accumulator and parsing continues. This allows GHC to report
2487 --   more than one parse error per file.
2488 --
2489 addError :: SrcSpan -> SDoc -> P ()
2490 addError srcspan msg
2491  = P $ \s@PState{messages=m} ->
2492        let
2493            m' d =
2494                let (ws, es) = m d
2495                    errormsg = mkErrMsg d srcspan alwaysQualify msg
2496                    es' = es `snocBag` errormsg
2497                in (ws, es')
2498        in POk s{messages=m'} ()
2499
2500 -- | Add a fatal error. This will be the last error reported by the parser, and
2501 --   the parser will not produce any result, ending in a 'PFailed' state.
2502 addFatalError :: SrcSpan -> SDoc -> P a
2503 addFatalError span msg =
2504   addError span msg >> P PFailed
2505
2506 -- | Add a warning to the accumulator.
2507 --   Use 'getMessages' to get the accumulated warnings.
2508 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
2509 addWarning option srcspan warning
2510  = P $ \s@PState{messages=m, options=o} ->
2511        let
2512            m' d =
2513                let (ws, es) = m d
2514                    warning' = makeIntoWarning (Reason option) $
2515                       mkWarnMsg d srcspan alwaysQualify warning
2516                    ws' = if warnopt option o then ws `snocBag` warning' else ws
2517                in (ws', es)
2518        in POk s{messages=m'} ()
2519
2520 addTabWarning :: RealSrcSpan -> P ()
2521 addTabWarning srcspan
2522  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
2523        let tf' = if isJust tf then tf else Just srcspan
2524            tc' = tc + 1
2525            s' = if warnopt Opt_WarnTabs o
2526                 then s{tab_first = tf', tab_count = tc'}
2527                 else s
2528        in POk s' ()
2529
2530 mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
2531 mkTabWarning PState{tab_first=tf, tab_count=tc} d =
2532   let middle = if tc == 1
2533         then text ""
2534         else text ", and in" <+> speakNOf (tc - 1) (text "further location")
2535       message = text "Tab character found here"
2536                 <> middle
2537                 <> text "."
2538                 $+$ text "Please use spaces instead."
2539   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
2540                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
2541
2542 -- | Get a bag of the errors that have been accumulated so far.
2543 --   Does not take -Werror into account.
2544 getErrorMessages :: PState -> DynFlags -> ErrorMessages
2545 getErrorMessages PState{messages=m} d =
2546   let (_, es) = m d in es
2547
2548 -- | Get the warnings and errors accumulated so far.
2549 --   Does not take -Werror into account.
2550 getMessages :: PState -> DynFlags -> Messages
2551 getMessages p@PState{messages=m} d =
2552   let (ws, es) = m d
2553       tabwarning = mkTabWarning p d
2554       ws' = maybe ws (`consBag` ws) tabwarning
2555   in (ws', es)
2556
2557 getContext :: P [LayoutContext]
2558 getContext = P $ \s@PState{context=ctx} -> POk s ctx
2559
2560 setContext :: [LayoutContext] -> P ()
2561 setContext ctx = P $ \s -> POk s{context=ctx} ()
2562
2563 popContext :: P ()
2564 popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
2565                               last_len = len, last_loc = last_loc }) ->
2566   case ctx of
2567         (_:tl) ->
2568           POk s{ context = tl } ()
2569         []     ->
2570           unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
2571
2572 -- Push a new layout context at the indentation of the last token read.
2573 pushCurrentContext :: GenSemic -> P ()
2574 pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->
2575     POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} ()
2576
2577 -- This is only used at the outer level of a module when the 'module' keyword is
2578 -- missing.
2579 pushModuleContext :: P ()
2580 pushModuleContext = pushCurrentContext generateSemic
2581
2582 getOffside :: P (Ordering, Bool)
2583 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
2584                 let offs = srcSpanStartCol loc in
2585                 let ord = case stk of
2586                             Layout n gen_semic : _ ->
2587                               --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
2588                               (compare offs n, gen_semic)
2589                             _ ->
2590                               (GT, dontGenerateSemic)
2591                 in POk s ord
2592
2593 -- ---------------------------------------------------------------------------
2594 -- Construct a parse error
2595
2596 srcParseErr
2597   :: ParserFlags
2598   -> StringBuffer       -- current buffer (placed just after the last token)
2599   -> Int                -- length of the previous token
2600   -> MsgDoc
2601 srcParseErr options buf len
2602   = if null token
2603          then text "parse error (possibly incorrect indentation or mismatched brackets)"
2604          else text "parse error on input" <+> quotes (text token)
2605               $$ ppWhen (not th_enabled && token == "$") -- #7396
2606                         (text "Perhaps you intended to use TemplateHaskell")
2607               $$ ppWhen (token == "<-")
2608                         (if mdoInLast100
2609                            then text "Perhaps you intended to use RecursiveDo"
2610                            else text "Perhaps this statement should be within a 'do' block?")
2611               $$ ppWhen (token == "=" && doInLast100) -- #15849
2612                         (text "Perhaps you need a 'let' in a 'do' block?"
2613                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
2614               $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429
2615                         (text "Perhaps you intended to use PatternSynonyms")
2616   where token = lexemeToString (offsetBytes (-len) buf) len
2617         pattern = decodePrevNChars 8 buf
2618         last100 = decodePrevNChars 100 buf
2619         doInLast100 = "do" `isInfixOf` last100
2620         mdoInLast100 = "mdo" `isInfixOf` last100
2621         th_enabled = ThBit `xtest` pExtsBitmap options
2622         ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
2623
2624 -- Report a parse failure, giving the span of the previous token as
2625 -- the location of the error.  This is the entry point for errors
2626 -- detected during parsing.
2627 srcParseFail :: P a
2628 srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
2629                             last_loc = last_loc } ->
2630     unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
2631
2632 -- A lexical error is reported at a particular position in the source file,
2633 -- not over a token range.
2634 lexError :: String -> P a
2635 lexError str = do
2636   loc <- getRealSrcLoc
2637   (AI end buf) <- getInput
2638   reportLexError loc end buf str
2639
2640 -- -----------------------------------------------------------------------------
2641 -- This is the top-level function: called from the parser each time a
2642 -- new token is to be read from the input.
2643
2644 lexer :: Bool -> (Located Token -> P a) -> P a
2645 lexer queueComments cont = do
2646   alr <- getBit AlternativeLayoutRuleBit
2647   let lexTokenFun = if alr then lexTokenAlr else lexToken
2648   (L span tok) <- lexTokenFun
2649   --trace ("token: " ++ show tok) $ do
2650
2651   case tok of
2652     ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
2653     _ -> return ()
2654
2655   if (queueComments && isDocComment tok)
2656     then queueComment (L (RealSrcSpan span) tok)
2657     else return ()
2658
2659   if (queueComments && isComment tok)
2660     then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
2661     else cont (L (RealSrcSpan span) tok)
2662
2663 lexTokenAlr :: P (RealLocated Token)
2664 lexTokenAlr = do mPending <- popPendingImplicitToken
2665                  t <- case mPending of
2666                       Nothing ->
2667                           do mNext <- popNextToken
2668                              t <- case mNext of
2669                                   Nothing -> lexToken
2670                                   Just next -> return next
2671                              alternativeLayoutRuleToken t
2672                       Just t ->
2673                           return t
2674                  setAlrLastLoc (getRealSrcSpan t)
2675                  case unRealSrcSpan t of
2676                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2677                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2678                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2679                      ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf)
2680                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2681                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2682                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2683                      _       -> return ()
2684                  return t
2685
2686 alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
2687 alternativeLayoutRuleToken t
2688     = do context <- getALRContext
2689          lastLoc <- getAlrLastLoc
2690          mExpectingOCurly <- getAlrExpectingOCurly
2691          transitional <- getBit ALRTransitionalBit
2692          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2693          setJustClosedExplicitLetBlock False
2694          let thisLoc = getRealSrcSpan t
2695              thisCol = srcSpanStartCol thisLoc
2696              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
2697          case (unRealSrcSpan t, context, mExpectingOCurly) of
2698              -- This case handles a GHC extension to the original H98
2699              -- layout rule...
2700              (ITocurly, _, Just alrLayout) ->
2701                  do setAlrExpectingOCurly Nothing
2702                     let isLet = case alrLayout of
2703                                 ALRLayoutLet -> True
2704                                 _ -> False
2705                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2706                     return t
2707              -- ...and makes this case unnecessary
2708              {-
2709              -- I think our implicit open-curly handling is slightly
2710              -- different to John's, in how it interacts with newlines
2711              -- and "in"
2712              (ITocurly, _, Just _) ->
2713                  do setAlrExpectingOCurly Nothing
2714                     setNextToken t
2715                     lexTokenAlr
2716              -}
2717              (_, ALRLayout _ col : _ls, Just expectingOCurly)
2718               | (thisCol > col) ||
2719                 (thisCol == col &&
2720                  isNonDecreasingIndentation expectingOCurly) ->
2721                  do setAlrExpectingOCurly Nothing
2722                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2723                     setNextToken t
2724                     return (L thisLoc ITvocurly)
2725               | otherwise ->
2726                  do setAlrExpectingOCurly Nothing
2727                     setPendingImplicitTokens [L lastLoc ITvccurly]
2728                     setNextToken t
2729                     return (L lastLoc ITvocurly)
2730              (_, _, Just expectingOCurly) ->
2731                  do setAlrExpectingOCurly Nothing
2732                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2733                     setNextToken t
2734                     return (L thisLoc ITvocurly)
2735              -- We do the [] cases earlier than in the spec, as we
2736              -- have an actual EOF token
2737              (ITeof, ALRLayout _ _ : ls, _) ->
2738                  do setALRContext ls
2739                     setNextToken t
2740                     return (L thisLoc ITvccurly)
2741              (ITeof, _, _) ->
2742                  return t
2743              -- the other ITeof case omitted; general case below covers it
2744              (ITin, _, _)
2745               | justClosedExplicitLetBlock ->
2746                  return t
2747              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2748               | newLine ->
2749                  do setPendingImplicitTokens [t]
2750                     setALRContext ls
2751                     return (L thisLoc ITvccurly)
2752              -- This next case is to handle a transitional issue:
2753              (ITwhere, ALRLayout _ col : ls, _)
2754               | newLine && thisCol == col && transitional ->
2755                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2756                                (RealSrcSpan thisLoc)
2757                                (transitionalAlternativeLayoutWarning
2758                                     "`where' clause at the same depth as implicit layout block")
2759                     setALRContext ls
2760                     setNextToken t
2761                     -- Note that we use lastLoc, as we may need to close
2762                     -- more layouts, or give a semicolon
2763                     return (L lastLoc ITvccurly)
2764              -- This next case is to handle a transitional issue:
2765              (ITvbar, ALRLayout _ col : ls, _)
2766               | newLine && thisCol == col && transitional ->
2767                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2768                                (RealSrcSpan thisLoc)
2769                                (transitionalAlternativeLayoutWarning
2770                                     "`|' at the same depth as implicit layout block")
2771                     setALRContext ls
2772                     setNextToken t
2773                     -- Note that we use lastLoc, as we may need to close
2774                     -- more layouts, or give a semicolon
2775                     return (L lastLoc ITvccurly)
2776              (_, ALRLayout _ col : ls, _)
2777               | newLine && thisCol == col ->
2778                  do setNextToken t
2779                     let loc = realSrcSpanStart thisLoc
2780                         zeroWidthLoc = mkRealSrcSpan loc loc
2781                     return (L zeroWidthLoc ITsemi)
2782               | newLine && thisCol < col ->
2783                  do setALRContext ls
2784                     setNextToken t
2785                     -- Note that we use lastLoc, as we may need to close
2786                     -- more layouts, or give a semicolon
2787                     return (L lastLoc ITvccurly)
2788              -- We need to handle close before open, as 'then' is both
2789              -- an open and a close
2790              (u, _, _)
2791               | isALRclose u ->
2792                  case context of
2793                  ALRLayout _ _ : ls ->
2794                      do setALRContext ls
2795                         setNextToken t
2796                         return (L thisLoc ITvccurly)
2797                  ALRNoLayout _ isLet : ls ->
2798                      do let ls' = if isALRopen u
2799                                      then ALRNoLayout (containsCommas u) False : ls
2800                                      else ls
2801                         setALRContext ls'
2802                         when isLet $ setJustClosedExplicitLetBlock True
2803                         return t
2804                  [] ->
2805                      do let ls = if isALRopen u
2806                                     then [ALRNoLayout (containsCommas u) False]
2807                                     else []
2808                         setALRContext ls
2809                         -- XXX This is an error in John's code, but
2810                         -- it looks reachable to me at first glance
2811                         return t
2812              (u, _, _)
2813               | isALRopen u ->
2814                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2815                     return t
2816              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2817                  do setALRContext ls
2818                     setPendingImplicitTokens [t]
2819                     return (L thisLoc ITvccurly)
2820              (ITin, ALRLayout _ _ : ls, _) ->
2821                  do setALRContext ls
2822                     setNextToken t
2823                     return (L thisLoc ITvccurly)
2824              -- the other ITin case omitted; general case below covers it
2825              (ITcomma, ALRLayout _ _ : ls, _)
2826               | topNoLayoutContainsCommas ls ->
2827                  do setALRContext ls
2828                     setNextToken t
2829                     return (L thisLoc ITvccurly)
2830              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2831                  do setALRContext ls
2832                     setPendingImplicitTokens [t]
2833                     return (L thisLoc ITvccurly)
2834              -- the other ITwhere case omitted; general case below covers it
2835              (_, _, _) -> return t
2836
2837 transitionalAlternativeLayoutWarning :: String -> SDoc
2838 transitionalAlternativeLayoutWarning msg
2839     = text "transitional layout will not be accepted in the future:"
2840    $$ text msg
2841
2842 isALRopen :: Token -> Bool
2843 isALRopen ITcase          = True
2844 isALRopen ITif            = True
2845 isALRopen ITthen          = True
2846 isALRopen IToparen        = True
2847 isALRopen ITobrack        = True
2848 isALRopen ITocurly        = True
2849 -- GHC Extensions:
2850 isALRopen IToubxparen     = True
2851 isALRopen ITparenEscape   = True
2852 isALRopen ITparenTyEscape = True
2853 isALRopen _               = False
2854
2855 isALRclose :: Token -> Bool
2856 isALRclose ITof     = True
2857 isALRclose ITthen   = True
2858 isALRclose ITelse   = True
2859 isALRclose ITcparen = True
2860 isALRclose ITcbrack = True
2861 isALRclose ITccurly = True
2862 -- GHC Extensions:
2863 isALRclose ITcubxparen = True
2864 isALRclose _        = False
2865
2866 isNonDecreasingIndentation :: ALRLayout -> Bool
2867 isNonDecreasingIndentation ALRLayoutDo = True
2868 isNonDecreasingIndentation _           = False
2869
2870 containsCommas :: Token -> Bool
2871 containsCommas IToparen = True
2872 containsCommas ITobrack = True
2873 -- John doesn't have {} as containing commas, but records contain them,
2874 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2875 -- (defaultInstallDirs).
2876 containsCommas ITocurly = True
2877 -- GHC Extensions:
2878 containsCommas IToubxparen = True
2879 containsCommas _        = False
2880
2881 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2882 topNoLayoutContainsCommas [] = False
2883 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2884 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2885
2886 lexToken :: P (RealLocated Token)
2887 lexToken = do
2888   inp@(AI loc1 buf) <- getInput
2889   sc <- getLexState
2890   exts <- getExts
2891   case alexScanUser exts inp sc of
2892     AlexEOF -> do
2893         let span = mkRealSrcSpan loc1 loc1
2894         setLastToken span 0
2895         return (L span ITeof)
2896     AlexError (AI loc2 buf) ->
2897         reportLexError loc1 loc2 buf "lexical error"
2898     AlexSkip inp2 _ -> do
2899         setInput inp2
2900         lexToken
2901     AlexToken inp2@(AI end buf2) _ t -> do
2902         setInput inp2
2903         let span = mkRealSrcSpan loc1 end
2904         let bytes = byteDiff buf buf2
2905         span `seq` setLastToken span bytes
2906         lt <- t span buf bytes
2907         case unRealSrcSpan lt of
2908           ITlineComment _  -> return lt
2909           ITblockComment _ -> return lt
2910           lt' -> do
2911             setLastTk lt'
2912             return lt
2913
2914 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
2915 reportLexError loc1 loc2 buf str
2916   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2917   | otherwise =
2918   let c = fst (nextChar buf)
2919   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2920      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2921      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2922
2923 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
2924 lexTokenStream buf loc dflags = unP go initState{ options = opts' }
2925     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2926           initState@PState{ options = opts } = mkPState dflags' buf loc
2927           opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts }
2928           go = do
2929             ltok <- lexer False return
2930             case ltok of
2931               L _ ITeof -> return []
2932               _ -> liftM (ltok:) go
2933
2934 linePrags = Map.singleton "line" linePrag
2935
2936 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2937                                  ("options_ghc", lex_string_prag IToptions_prag),
2938                                  ("options_haddock", lex_string_prag ITdocOptions),
2939                                  ("language", token ITlanguage_prag),
2940                                  ("include", lex_string_prag ITinclude_prag)])
2941
2942 ignoredPrags = Map.fromList (map ignored pragmas)
2943                where ignored opt = (opt, nested_comment lexToken)
2944                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2945                      options_pragmas = map ("options_" ++) impls
2946                      -- CFILES is a hugs-only thing.
2947                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2948
2949 oneWordPrags = Map.fromList [
2950      ("rules", rulePrag),
2951      ("inline",
2952          strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),
2953      ("inlinable",
2954          strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
2955      ("inlineable",
2956          strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
2957                                     -- Spelling variant
2958      ("notinline",
2959          strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),
2960      ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
2961      ("source", strtoken (\s -> ITsource_prag (SourceText s))),
2962      ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
2963      ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
2964      ("scc", strtoken (\s -> ITscc_prag (SourceText s))),
2965      ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))),
2966      ("core", strtoken (\s -> ITcore_prag (SourceText s))),
2967      ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
2968      ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
2969      ("ann", strtoken (\s -> ITann_prag (SourceText s))),
2970      ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
2971      ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
2972      ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
2973      ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
2974      ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
2975      ("ctype", strtoken (\s -> ITctype (SourceText s))),
2976      ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
2977      ("column", columnPrag)
2978      ]
2979
2980 twoWordPrags = Map.fromList [
2981      ("inline conlike",
2982          strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),
2983      ("notinline conlike",
2984          strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),
2985      ("specialize inline",
2986          strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
2987      ("specialize notinline",
2988          strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
2989      ]
2990
2991 dispatch_pragmas :: Map String Action -> Action
2992 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
2993                                        Just found -> found span buf len
2994                                        Nothing -> lexError "unknown pragma"
2995
2996 known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
2997 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
2998  = isKnown && nextCharIsNot curbuf pragmaNameChar
2999     where l = lexemeToString startbuf (byteDiff startbuf curbuf)
3000           isKnown = isJust $ Map.lookup (clean_pragma l) prags
3001           pragmaNameChar c = isAlphaNum c || c == '_'
3002
3003 clean_pragma :: String -> String
3004 clean_pragma prag = canon_ws (map toLower (unprefix prag))
3005                     where unprefix prag' = case stripPrefix "{-#" prag' of
3006                                              Just rest -> rest
3007                                              Nothing -> prag'
3008                           canonical prag' = case prag' of
3009                                               "noinline" -> "notinline"
3010                                               "specialise" -> "specialize"
3011                                               "constructorlike" -> "conlike"
3012                                               _ -> prag'
3013                           canon_ws s = unwords (map canonical (words s))
3014
3015
3016
3017 {-
3018 %************************************************************************
3019 %*                                                                      *
3020         Helper functions for generating annotations in the parser
3021 %*                                                                      *
3022 %************************************************************************
3023 -}
3024
3025 -- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
3026 --   the AST construct the annotation belongs to; together with the
3027 --   AnnKeywordId, this is the key of the annotation map.
3028 --
3029 --   This type is useful for places in the parser where it is not yet
3030 --   known what SrcSpan an annotation should be added to.  The most
3031 --   common situation is when we are parsing a list: the annotations
3032 --   need to be associated with the AST element that *contains* the
3033 --   list, not the list itself.  'AddAnn' lets us defer adding the
3034 --   annotations until we finish parsing the list and are now parsing
3035 --   the enclosing element; we then apply the 'AddAnn' to associate
3036 --   the annotations.  Another common situation is where a common fragment of
3037 --   the AST has been factored out but there is no separate AST node for
3038 --   this fragment (this occurs in class and data declarations). In this
3039 --   case, the annotation belongs to the parent data declaration.
3040 --
3041 --   The usual way an 'AddAnn' is created is using the 'mj' ("make jump")
3042 --   function, and then it can be discharged using the 'ams' function.
3043 type AddAnn = SrcSpan -> P ()
3044
3045 addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
3046               -> AnnKeywordId     -- The first two parameters are the key
3047               -> SrcSpan          -- The location of the keyword itself
3048               -> P ()
3049 addAnnotation l a v = do
3050   addAnnotationOnly l a v
3051   allocateComments l
3052
3053 addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
3054 addAnnotationOnly l a v = P $ \s -> POk s {
3055   annotations = ((l,a), [v]) : annotations s
3056   } ()
3057
3058 -- |Given a location and a list of AddAnn, apply them all to the location.
3059 addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
3060 addAnnsAt loc anns = mapM_ (\a -> a loc) anns
3061
3062 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
3063 -- 'AddAnn' values for the opening and closing bordering on the start
3064 -- and end of the span
3065 mkParensApiAnn :: SrcSpan -> [AddAnn]
3066 mkParensApiAnn (UnhelpfulSpan _)  = []
3067 mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
3068   where
3069     mj a l = (\s -> addAnnotation s a l)
3070     f = srcSpanFile ss
3071     sl = srcSpanStartLine ss
3072     sc = srcSpanStartCol ss
3073     el = srcSpanEndLine ss
3074     ec = srcSpanEndCol ss
3075     lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
3076     lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
3077
3078 queueComment :: Located Token -> P()
3079 queueComment c = P $ \s -> POk s {
3080   comment_q = commentToAnnotation c : comment_q s
3081   } ()
3082
3083 -- | Go through the @comment_q@ in @PState@ and remove all comments
3084 -- that belong within the given span
3085 allocateComments :: SrcSpan -> P ()
3086 allocateComments ss = P $ \s ->
3087   let
3088     (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
3089     (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
3090     comment_q' = before ++ after
3091     newAnns = if null middle then []
3092                              else [(ss,middle)]
3093   in
3094     POk s {
3095        comment_q = comment_q'
3096      , annotations_comments = newAnns ++ (annotations_comments s)
3097      } ()
3098
3099 commentToAnnotation :: Located Token -> Located AnnotationComment
3100 commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
3101 commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)
3102 commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
3103 commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)
3104 commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)
3105 commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)
3106 commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)
3107 commentToAnnotation _                           = panic "commentToAnnotation"
3108
3109 -- ---------------------------------------------------------------------
3110
3111 isComment :: Token -> Bool
3112 isComment (ITlineComment     _)   = True
3113 isComment (ITblockComment    _)   = True
3114 isComment _ = False
3115
3116 isDocComment :: Token -> Bool
3117 isDocComment (ITdocCommentNext  _)   = True
3118 isDocComment (ITdocCommentPrev  _)   = True
3119 isDocComment (ITdocCommentNamed _)   = True
3120 isDocComment (ITdocSection      _ _) = True
3121 isDocComment (ITdocOptions      _)   = True
3122 isDocComment _ = False
3123 }