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