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