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