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