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