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