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