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