2ce0ac67603f0db82bd55b663976f42e3cd5d67f
[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         SrcSpan         -- The start and end of the text span related to
1804                         -- the error.  Might be used in environments which can
1805                         -- show this span, e.g. by highlighting it.
1806         MsgDoc          -- The error message
1807
1808 -- | Test whether a 'WarningFlag' is set
1809 warnopt :: WarningFlag -> ParserFlags -> Bool
1810 warnopt f options = f `EnumSet.member` pWarningFlags options
1811
1812 -- | Test whether a 'LangExt.Extension' is set
1813 extopt :: LangExt.Extension -> ParserFlags -> Bool
1814 extopt f options = f `EnumSet.member` pExtensionFlags options
1815
1816 -- | The subset of the 'DynFlags' used by the parser
1817 data ParserFlags = ParserFlags {
1818     pWarningFlags   :: EnumSet WarningFlag
1819   , pExtensionFlags :: EnumSet LangExt.Extension
1820   , pThisPackage    :: UnitId      -- ^ key of package currently being compiled
1821   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
1822   }
1823
1824 data PState = PState {
1825         buffer     :: StringBuffer,
1826         options    :: ParserFlags,
1827         -- This needs to take DynFlags as an argument until
1828         -- we have a fix for #10143
1829         messages   :: DynFlags -> Messages,
1830         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file
1831         tab_count  :: !Int,              -- number of tab warnings in the file
1832         last_tk    :: Maybe Token,
1833         last_loc   :: RealSrcSpan, -- pos of previous token
1834         last_len   :: !Int,        -- len of previous token
1835         loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)
1836         context    :: [LayoutContext],
1837         lex_state  :: [Int],
1838         srcfiles   :: [FastString],
1839         -- Used in the alternative layout rule:
1840         -- These tokens are the next ones to be sent out. They are
1841         -- just blindly emitted, without the rule looking at them again:
1842         alr_pending_implicit_tokens :: [RealLocated Token],
1843         -- This is the next token to be considered or, if it is Nothing,
1844         -- we need to get the next token from the input stream:
1845         alr_next_token :: Maybe (RealLocated Token),
1846         -- This is what we consider to be the location of the last token
1847         -- emitted:
1848         alr_last_loc :: RealSrcSpan,
1849         -- The stack of layout contexts:
1850         alr_context :: [ALRContext],
1851         -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
1852         -- us what sort of layout the '{' will open:
1853         alr_expecting_ocurly :: Maybe ALRLayout,
1854         -- Have we just had the '}' for a let block? If so, than an 'in'
1855         -- token doesn't need to close anything:
1856         alr_justClosedExplicitLetBlock :: Bool,
1857
1858         -- The next three are used to implement Annotations giving the
1859         -- locations of 'noise' tokens in the source, so that users of
1860         -- the GHC API can do source to source conversions.
1861         -- See note [Api annotations] in ApiAnnotation.hs
1862         annotations :: [(ApiAnnKey,[SrcSpan])],
1863         comment_q :: [Located AnnotationComment],
1864         annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
1865      }
1866         -- last_loc and last_len are used when generating error messages,
1867         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1868         -- current token to happyError, we could at least get rid of last_len.
1869         -- Getting rid of last_loc would require finding another way to
1870         -- implement pushCurrentContext (which is only called from one place).
1871
1872 data ALRContext = ALRNoLayout Bool{- does it contain commas? -}
1873                               Bool{- is it a 'let' block? -}
1874                 | ALRLayout ALRLayout Int
1875 data ALRLayout = ALRLayoutLet
1876                | ALRLayoutWhere
1877                | ALRLayoutOf
1878                | ALRLayoutDo
1879
1880 newtype P a = P { unP :: PState -> ParseResult a }
1881
1882 instance Functor P where
1883   fmap = liftM
1884
1885 instance Applicative P where
1886   pure = returnP
1887   (<*>) = ap
1888
1889 instance Monad P where
1890   (>>=) = thenP
1891   fail = failP
1892
1893 #if __GLASGOW_HASKELL__ > 710
1894 instance MonadFail P where
1895   fail = failP
1896 #endif
1897
1898 returnP :: a -> P a
1899 returnP a = a `seq` (P $ \s -> POk s a)
1900
1901 thenP :: P a -> (a -> P b) -> P b
1902 (P m) `thenP` k = P $ \ s ->
1903         case m s of
1904                 POk s1 a         -> (unP (k a)) s1
1905                 PFailed span err -> PFailed span err
1906
1907 failP :: String -> P a
1908 failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1909
1910 failMsgP :: String -> P a
1911 failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1912
1913 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
1914 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
1915
1916 failSpanMsgP :: SrcSpan -> SDoc -> P a
1917 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1918
1919 getPState :: P PState
1920 getPState = P $ \s -> POk s s
1921
1922 withThisPackage :: (UnitId -> a) -> P a
1923 withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o))
1924
1925 extension :: (ExtsBitmap -> Bool) -> P Bool
1926 extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s)
1927
1928 getExts :: P ExtsBitmap
1929 getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
1930
1931 setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()
1932 setExts f = P $ \s -> POk s {
1933   options =
1934     let p = options s
1935     in  p { pExtsBitmap = f (pExtsBitmap p) }
1936   } ()
1937
1938 setSrcLoc :: RealSrcLoc -> P ()
1939 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1940
1941 getSrcLoc :: P RealSrcLoc
1942 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1943
1944 addSrcFile :: FastString -> P ()
1945 addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
1946
1947 setLastToken :: RealSrcSpan -> Int -> P ()
1948 setLastToken loc len = P $ \s -> POk s {
1949   last_loc=loc,
1950   last_len=len
1951   } ()
1952
1953 setLastTk :: Token -> P ()
1954 setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
1955
1956 getLastTk :: P (Maybe Token)
1957 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
1958
1959 data AlexInput = AI RealSrcLoc StringBuffer
1960
1961 alexInputPrevChar :: AlexInput -> Char
1962 alexInputPrevChar (AI _ buf) = prevChar buf '\n'
1963
1964 -- backwards compatibility for Alex 2.x
1965 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1966 alexGetChar inp = case alexGetByte inp of
1967                     Nothing    -> Nothing
1968                     Just (b,i) -> c `seq` Just (c,i)
1969                        where c = chr $ fromIntegral b
1970
1971 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
1972 alexGetByte (AI loc s)
1973   | atEnd s   = Nothing
1974   | otherwise = byte `seq` loc' `seq` s' `seq`
1975                 --trace (show (ord c)) $
1976                 Just (byte, (AI loc' s'))
1977   where (c,s') = nextChar s
1978         loc'   = advanceSrcLoc loc c
1979         byte   = fromIntegral $ ord adj_c
1980
1981         non_graphic     = '\x00'
1982         upper           = '\x01'
1983         lower           = '\x02'
1984         digit           = '\x03'
1985         symbol          = '\x04'
1986         space           = '\x05'
1987         other_graphic   = '\x06'
1988         uniidchar       = '\x07'
1989
1990         adj_c
1991           | c <= '\x07' = non_graphic
1992           | c <= '\x7f' = c
1993           -- Alex doesn't handle Unicode, so when Unicode
1994           -- character is encountered we output these values
1995           -- with the actual character value hidden in the state.
1996           | otherwise =
1997                 -- NB: The logic behind these definitions is also reflected
1998                 -- in basicTypes/Lexeme.hs
1999                 -- Any changes here should likely be reflected there.
2000
2001                 case generalCategory c of
2002                   UppercaseLetter       -> upper
2003                   LowercaseLetter       -> lower
2004                   TitlecaseLetter       -> upper
2005                   ModifierLetter        -> uniidchar -- see #10196
2006                   OtherLetter           -> lower -- see #1103
2007                   NonSpacingMark        -> uniidchar -- see #7650
2008                   SpacingCombiningMark  -> other_graphic
2009                   EnclosingMark         -> other_graphic
2010                   DecimalNumber         -> digit
2011                   LetterNumber          -> other_graphic
2012                   OtherNumber           -> digit -- see #4373
2013                   ConnectorPunctuation  -> symbol
2014                   DashPunctuation       -> symbol
2015                   OpenPunctuation       -> other_graphic
2016                   ClosePunctuation      -> other_graphic
2017                   InitialQuote          -> other_graphic
2018                   FinalQuote            -> other_graphic
2019                   OtherPunctuation      -> symbol
2020                   MathSymbol            -> symbol
2021                   CurrencySymbol        -> symbol
2022                   ModifierSymbol        -> symbol
2023                   OtherSymbol           -> symbol
2024                   Space                 -> space
2025                   _other                -> non_graphic
2026
2027 -- This version does not squash unicode characters, it is used when
2028 -- lexing strings.
2029 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
2030 alexGetChar' (AI loc s)
2031   | atEnd s   = Nothing
2032   | otherwise = c `seq` loc' `seq` s' `seq`
2033                 --trace (show (ord c)) $
2034                 Just (c, (AI loc' s'))
2035   where (c,s') = nextChar s
2036         loc'   = advanceSrcLoc loc c
2037
2038 getInput :: P AlexInput
2039 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
2040
2041 setInput :: AlexInput -> P ()
2042 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
2043
2044 nextIsEOF :: P Bool
2045 nextIsEOF = do
2046   AI _ s <- getInput
2047   return $ atEnd s
2048
2049 pushLexState :: Int -> P ()
2050 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
2051
2052 popLexState :: P Int
2053 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
2054
2055 getLexState :: P Int
2056 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
2057
2058 popNextToken :: P (Maybe (RealLocated Token))
2059 popNextToken
2060     = P $ \s@PState{ alr_next_token = m } ->
2061               POk (s {alr_next_token = Nothing}) m
2062
2063 activeContext :: P Bool
2064 activeContext = do
2065   ctxt <- getALRContext
2066   expc <- getAlrExpectingOCurly
2067   impt <- implicitTokenPending
2068   case (ctxt,expc) of
2069     ([],Nothing) -> return impt
2070     _other       -> return True
2071
2072 setAlrLastLoc :: RealSrcSpan -> P ()
2073 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
2074
2075 getAlrLastLoc :: P RealSrcSpan
2076 getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
2077
2078 getALRContext :: P [ALRContext]
2079 getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
2080
2081 setALRContext :: [ALRContext] -> P ()
2082 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
2083
2084 getALRTransitional :: P Bool
2085 getALRTransitional = P $ \s@PState {options = o} ->
2086   POk s (extopt LangExt.AlternativeLayoutRuleTransitional o)
2087
2088 getJustClosedExplicitLetBlock :: P Bool
2089 getJustClosedExplicitLetBlock
2090  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
2091
2092 setJustClosedExplicitLetBlock :: Bool -> P ()
2093 setJustClosedExplicitLetBlock b
2094  = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
2095
2096 setNextToken :: RealLocated Token -> P ()
2097 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
2098
2099 implicitTokenPending :: P Bool
2100 implicitTokenPending
2101     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
2102               case ts of
2103               [] -> POk s False
2104               _  -> POk s True
2105
2106 popPendingImplicitToken :: P (Maybe (RealLocated Token))
2107 popPendingImplicitToken
2108     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
2109               case ts of
2110               [] -> POk s Nothing
2111               (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
2112
2113 setPendingImplicitTokens :: [RealLocated Token] -> P ()
2114 setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
2115
2116 getAlrExpectingOCurly :: P (Maybe ALRLayout)
2117 getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
2118
2119 setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
2120 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
2121
2122 -- for reasons of efficiency, flags indicating language extensions (eg,
2123 -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap
2124 -- stored in an unboxed Word64
2125 type ExtsBitmap = Word64
2126
2127 xbit :: ExtBits -> ExtsBitmap
2128 xbit = bit . fromEnum
2129
2130 xtest :: ExtBits -> ExtsBitmap -> Bool
2131 xtest ext xmap = testBit xmap (fromEnum ext)
2132
2133 data ExtBits
2134   = FfiBit
2135   | InterruptibleFfiBit
2136   | CApiFfiBit
2137   | ParrBit
2138   | ArrowsBit
2139   | ThBit
2140   | ThQuotesBit
2141   | IpBit
2142   | OverloadedLabelsBit -- #x overloaded labels
2143   | ExplicitForallBit -- the 'forall' keyword and '.' symbol
2144   | BangPatBit -- Tells the parser to understand bang-patterns
2145                -- (doesn't affect the lexer)
2146   | PatternSynonymsBit -- pattern synonyms
2147   | HaddockBit-- Lex and parse Haddock comments
2148   | MagicHashBit -- "#" in both functions and operators
2149   | RecursiveDoBit -- mdo
2150   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
2151   | UnboxedTuplesBit -- (# and #)
2152   | UnboxedSumsBit -- (# and #)
2153   | DatatypeContextsBit
2154   | TransformComprehensionsBit
2155   | QqBit -- enable quasiquoting
2156   | InRulePragBit
2157   | RawTokenStreamBit -- producing a token stream with all comments included
2158   | SccProfilingOnBit
2159   | HpcBit
2160   | AlternativeLayoutRuleBit
2161   | RelaxedLayoutBit
2162   | NondecreasingIndentationBit
2163   | SafeHaskellBit
2164   | TraditionalRecordSyntaxBit
2165   | ExplicitNamespacesBit
2166   | LambdaCaseBit
2167   | BinaryLiteralsBit
2168   | NegativeLiteralsBit
2169   | TypeApplicationsBit
2170   | StaticPointersBit
2171   deriving Enum
2172
2173
2174 always :: ExtsBitmap -> Bool
2175 always           _     = True
2176 parrEnabled :: ExtsBitmap -> Bool
2177 parrEnabled = xtest ParrBit
2178 arrowsEnabled :: ExtsBitmap -> Bool
2179 arrowsEnabled = xtest ArrowsBit
2180 thEnabled :: ExtsBitmap -> Bool
2181 thEnabled = xtest ThBit
2182 thQuotesEnabled :: ExtsBitmap -> Bool
2183 thQuotesEnabled = xtest ThQuotesBit
2184 ipEnabled :: ExtsBitmap -> Bool
2185 ipEnabled = xtest IpBit
2186 overloadedLabelsEnabled :: ExtsBitmap -> Bool
2187 overloadedLabelsEnabled = xtest OverloadedLabelsBit
2188 explicitForallEnabled :: ExtsBitmap -> Bool
2189 explicitForallEnabled = xtest ExplicitForallBit
2190 bangPatEnabled :: ExtsBitmap -> Bool
2191 bangPatEnabled = xtest BangPatBit
2192 haddockEnabled :: ExtsBitmap -> Bool
2193 haddockEnabled = xtest HaddockBit
2194 magicHashEnabled :: ExtsBitmap -> Bool
2195 magicHashEnabled = xtest MagicHashBit
2196 unicodeSyntaxEnabled :: ExtsBitmap -> Bool
2197 unicodeSyntaxEnabled = xtest UnicodeSyntaxBit
2198 unboxedTuplesEnabled :: ExtsBitmap -> Bool
2199 unboxedTuplesEnabled = xtest UnboxedTuplesBit
2200 unboxedSumsEnabled :: ExtsBitmap -> Bool
2201 unboxedSumsEnabled = xtest UnboxedSumsBit
2202 datatypeContextsEnabled :: ExtsBitmap -> Bool
2203 datatypeContextsEnabled = xtest DatatypeContextsBit
2204 qqEnabled :: ExtsBitmap -> Bool
2205 qqEnabled = xtest QqBit
2206 inRulePrag :: ExtsBitmap -> Bool
2207 inRulePrag = xtest InRulePragBit
2208 rawTokenStreamEnabled :: ExtsBitmap -> Bool
2209 rawTokenStreamEnabled = xtest RawTokenStreamBit
2210 alternativeLayoutRule :: ExtsBitmap -> Bool
2211 alternativeLayoutRule = xtest AlternativeLayoutRuleBit
2212 hpcEnabled :: ExtsBitmap -> Bool
2213 hpcEnabled = xtest HpcBit
2214 relaxedLayout :: ExtsBitmap -> Bool
2215 relaxedLayout = xtest RelaxedLayoutBit
2216 nondecreasingIndentation :: ExtsBitmap -> Bool
2217 nondecreasingIndentation = xtest NondecreasingIndentationBit
2218 sccProfilingOn :: ExtsBitmap -> Bool
2219 sccProfilingOn = xtest SccProfilingOnBit
2220 traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool
2221 traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit
2222
2223 explicitNamespacesEnabled :: ExtsBitmap -> Bool
2224 explicitNamespacesEnabled = xtest ExplicitNamespacesBit
2225 lambdaCaseEnabled :: ExtsBitmap -> Bool
2226 lambdaCaseEnabled = xtest LambdaCaseBit
2227 binaryLiteralsEnabled :: ExtsBitmap -> Bool
2228 binaryLiteralsEnabled = xtest BinaryLiteralsBit
2229 negativeLiteralsEnabled :: ExtsBitmap -> Bool
2230 negativeLiteralsEnabled = xtest NegativeLiteralsBit
2231 patternSynonymsEnabled :: ExtsBitmap -> Bool
2232 patternSynonymsEnabled = xtest PatternSynonymsBit
2233 typeApplicationEnabled :: ExtsBitmap -> Bool
2234 typeApplicationEnabled = xtest TypeApplicationsBit
2235 staticPointersEnabled :: ExtsBitmap -> Bool
2236 staticPointersEnabled = xtest StaticPointersBit
2237
2238 -- PState for parsing options pragmas
2239 --
2240 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2241 pragState dynflags buf loc = (mkPState dynflags buf loc) {
2242                                  lex_state = [bol, option_prags, 0]
2243                              }
2244
2245 -- | Extracts the flag information needed for parsing
2246 mkParserFlags :: DynFlags -> ParserFlags
2247 mkParserFlags flags =
2248     ParserFlags {
2249       pWarningFlags = DynFlags.warningFlags flags
2250     , pExtensionFlags = DynFlags.extensionFlags flags
2251     , pThisPackage = DynFlags.thisPackage flags
2252     , pExtsBitmap = bitmap
2253     }
2254   where
2255       bitmap =     FfiBit                      `setBitIf` xopt LangExt.ForeignFunctionInterface flags
2256                .|. InterruptibleFfiBit         `setBitIf` xopt LangExt.InterruptibleFFI         flags
2257                .|. CApiFfiBit                  `setBitIf` xopt LangExt.CApiFFI                  flags
2258                .|. ParrBit                     `setBitIf` xopt LangExt.ParallelArrays           flags
2259                .|. ArrowsBit                   `setBitIf` xopt LangExt.Arrows                   flags
2260                .|. ThBit                       `setBitIf` xopt LangExt.TemplateHaskell          flags
2261                .|. ThQuotesBit                 `setBitIf` xopt LangExt.TemplateHaskellQuotes    flags
2262                .|. QqBit                       `setBitIf` xopt LangExt.QuasiQuotes              flags
2263                .|. IpBit                       `setBitIf` xopt LangExt.ImplicitParams           flags
2264                .|. OverloadedLabelsBit         `setBitIf` xopt LangExt.OverloadedLabels         flags
2265                .|. ExplicitForallBit           `setBitIf` xopt LangExt.ExplicitForAll           flags
2266                .|. BangPatBit                  `setBitIf` xopt LangExt.BangPatterns             flags
2267                .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                      flags
2268                .|. MagicHashBit                `setBitIf` xopt LangExt.MagicHash                flags
2269                .|. RecursiveDoBit              `setBitIf` xopt LangExt.RecursiveDo              flags
2270                .|. UnicodeSyntaxBit            `setBitIf` xopt LangExt.UnicodeSyntax            flags
2271                .|. UnboxedTuplesBit            `setBitIf` xopt LangExt.UnboxedTuples            flags
2272                .|. UnboxedSumsBit              `setBitIf` xopt LangExt.UnboxedSums              flags
2273                .|. DatatypeContextsBit         `setBitIf` xopt LangExt.DatatypeContexts         flags
2274                .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.TransformListComp        flags
2275                .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.MonadComprehensions      flags
2276                .|. RawTokenStreamBit           `setBitIf` gopt Opt_KeepRawTokenStream           flags
2277                .|. HpcBit                      `setBitIf` gopt Opt_Hpc                          flags
2278                .|. AlternativeLayoutRuleBit    `setBitIf` xopt LangExt.AlternativeLayoutRule    flags
2279                .|. RelaxedLayoutBit            `setBitIf` xopt LangExt.RelaxedLayout            flags
2280                .|. SccProfilingOnBit           `setBitIf` gopt Opt_SccProfilingOn               flags
2281                .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags
2282                .|. SafeHaskellBit              `setBitIf` safeImportsOn                         flags
2283                .|. TraditionalRecordSyntaxBit  `setBitIf` xopt LangExt.TraditionalRecordSyntax  flags
2284                .|. ExplicitNamespacesBit       `setBitIf` xopt LangExt.ExplicitNamespaces flags
2285                .|. LambdaCaseBit               `setBitIf` xopt LangExt.LambdaCase               flags
2286                .|. BinaryLiteralsBit           `setBitIf` xopt LangExt.BinaryLiterals           flags
2287                .|. NegativeLiteralsBit         `setBitIf` xopt LangExt.NegativeLiterals         flags
2288                .|. PatternSynonymsBit          `setBitIf` xopt LangExt.PatternSynonyms          flags
2289                .|. TypeApplicationsBit         `setBitIf` xopt LangExt.TypeApplications         flags
2290                .|. StaticPointersBit           `setBitIf` xopt LangExt.StaticPointers           flags
2291
2292       setBitIf :: ExtBits -> Bool -> ExtsBitmap
2293       b `setBitIf` cond | cond      = xbit b
2294                         | otherwise = 0
2295
2296 -- | Creates a parse state from a 'DynFlags' value
2297 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2298 mkPState flags = mkPStatePure (mkParserFlags flags)
2299
2300 -- | Creates a parse state from a 'ParserFlags' value
2301 mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
2302 mkPStatePure options buf loc =
2303   PState {
2304       buffer        = buf,
2305       options       = options,
2306       messages      = const emptyMessages,
2307       tab_first     = Nothing,
2308       tab_count     = 0,
2309       last_tk       = Nothing,
2310       last_loc      = mkRealSrcSpan loc loc,
2311       last_len      = 0,
2312       loc           = loc,
2313       context       = [],
2314       lex_state     = [bol, 0],
2315       srcfiles      = [],
2316       alr_pending_implicit_tokens = [],
2317       alr_next_token = Nothing,
2318       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
2319       alr_context = [],
2320       alr_expecting_ocurly = Nothing,
2321       alr_justClosedExplicitLetBlock = False,
2322       annotations = [],
2323       comment_q = [],
2324       annotations_comments = []
2325     }
2326
2327 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
2328 addWarning option srcspan warning
2329  = P $ \s@PState{messages=m, options=o} ->
2330        let
2331            m' d =
2332                let (ws, es) = m d
2333                    warning' = makeIntoWarning (Reason option) $
2334                       mkWarnMsg d srcspan alwaysQualify warning
2335                    ws' = if warnopt option o then ws `snocBag` warning' else ws
2336                in (ws', es)
2337        in POk s{messages=m'} ()
2338
2339 addTabWarning :: RealSrcSpan -> P ()
2340 addTabWarning srcspan
2341  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
2342        let tf' = if isJust tf then tf else Just srcspan
2343            tc' = tc + 1
2344            s' = if warnopt Opt_WarnTabs o
2345                 then s{tab_first = tf', tab_count = tc'}
2346                 else s
2347        in POk s' ()
2348
2349 mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
2350 mkTabWarning PState{tab_first=tf, tab_count=tc} d =
2351   let middle = if tc == 1
2352         then text ""
2353         else text ", and in" <+> speakNOf (tc - 1) (text "further location")
2354       message = text "Tab character found here"
2355                 <> middle
2356                 <> text "."
2357                 $+$ text "Please use spaces instead."
2358   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
2359                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
2360
2361 getMessages :: PState -> DynFlags -> Messages
2362 getMessages p@PState{messages=m} d =
2363   let (ws, es) = m d
2364       tabwarning = mkTabWarning p d
2365       ws' = maybe ws (`consBag` ws) tabwarning
2366   in (ws', es)
2367
2368 getContext :: P [LayoutContext]
2369 getContext = P $ \s@PState{context=ctx} -> POk s ctx
2370
2371 setContext :: [LayoutContext] -> P ()
2372 setContext ctx = P $ \s -> POk s{context=ctx} ()
2373
2374 popContext :: P ()
2375 popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
2376                               last_len = len, last_loc = last_loc }) ->
2377   case ctx of
2378         (_:tl) -> POk s{ context = tl } ()
2379         []     -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
2380
2381 -- Push a new layout context at the indentation of the last token read.
2382 pushCurrentContext :: GenSemic -> P ()
2383 pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->
2384     POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} ()
2385
2386 -- This is only used at the outer level of a module when the 'module' keyword is
2387 -- missing.
2388 pushModuleContext :: P ()
2389 pushModuleContext = pushCurrentContext generateSemic
2390
2391 getOffside :: P (Ordering, Bool)
2392 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
2393                 let offs = srcSpanStartCol loc in
2394                 let ord = case stk of
2395                             Layout n gen_semic : _ ->
2396                               --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
2397                               (compare offs n, gen_semic)
2398                             _ ->
2399                               (GT, dontGenerateSemic)
2400                 in POk s ord
2401
2402 -- ---------------------------------------------------------------------------
2403 -- Construct a parse error
2404
2405 srcParseErr
2406   :: ParserFlags
2407   -> StringBuffer       -- current buffer (placed just after the last token)
2408   -> Int                -- length of the previous token
2409   -> MsgDoc
2410 srcParseErr options buf len
2411   = if null token
2412          then text "parse error (possibly incorrect indentation or mismatched brackets)"
2413          else text "parse error on input" <+> quotes (text token)
2414               $$ ppWhen (not th_enabled && token == "$") -- #7396
2415                         (text "Perhaps you intended to use TemplateHaskell")
2416               $$ ppWhen (token == "<-")
2417                         (if mdoInLast100
2418                            then text "Perhaps you intended to use RecursiveDo"
2419                            else text "Perhaps this statement should be within a 'do' block?")
2420               $$ ppWhen (token == "=")
2421                         (text "Perhaps you need a 'let' in a 'do' block?"
2422                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
2423               $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429
2424                         (text "Perhaps you intended to use PatternSynonyms")
2425   where token = lexemeToString (offsetBytes (-len) buf) len
2426         pattern = decodePrevNChars 8 buf
2427         last100 = decodePrevNChars 100 buf
2428         mdoInLast100 = "mdo" `isInfixOf` last100
2429         th_enabled = extopt LangExt.TemplateHaskell options
2430         ps_enabled = extopt LangExt.PatternSynonyms options
2431
2432 -- Report a parse failure, giving the span of the previous token as
2433 -- the location of the error.  This is the entry point for errors
2434 -- detected during parsing.
2435 srcParseFail :: P a
2436 srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len,
2437                             last_loc = last_loc } ->
2438     PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
2439
2440 -- A lexical error is reported at a particular position in the source file,
2441 -- not over a token range.
2442 lexError :: String -> P a
2443 lexError str = do
2444   loc <- getSrcLoc
2445   (AI end buf) <- getInput
2446   reportLexError loc end buf str
2447
2448 -- -----------------------------------------------------------------------------
2449 -- This is the top-level function: called from the parser each time a
2450 -- new token is to be read from the input.
2451
2452 lexer :: Bool -> (Located Token -> P a) -> P a
2453 lexer queueComments cont = do
2454   alr <- extension alternativeLayoutRule
2455   let lexTokenFun = if alr then lexTokenAlr else lexToken
2456   (L span tok) <- lexTokenFun
2457   --trace ("token: " ++ show tok) $ do
2458
2459   case tok of
2460     ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
2461     _ -> return ()
2462
2463   if (queueComments && isDocComment tok)
2464     then queueComment (L (RealSrcSpan span) tok)
2465     else return ()
2466
2467   if (queueComments && isComment tok)
2468     then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
2469     else cont (L (RealSrcSpan span) tok)
2470
2471 lexTokenAlr :: P (RealLocated Token)
2472 lexTokenAlr = do mPending <- popPendingImplicitToken
2473                  t <- case mPending of
2474                       Nothing ->
2475                           do mNext <- popNextToken
2476                              t <- case mNext of
2477                                   Nothing -> lexToken
2478                                   Just next -> return next
2479                              alternativeLayoutRuleToken t
2480                       Just t ->
2481                           return t
2482                  setAlrLastLoc (getLoc t)
2483                  case unLoc t of
2484                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2485                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2486                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2487                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2488                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2489                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2490                      _       -> return ()
2491                  return t
2492
2493 alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
2494 alternativeLayoutRuleToken t
2495     = do context <- getALRContext
2496          lastLoc <- getAlrLastLoc
2497          mExpectingOCurly <- getAlrExpectingOCurly
2498          transitional <- getALRTransitional
2499          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2500          setJustClosedExplicitLetBlock False
2501          let thisLoc = getLoc t
2502              thisCol = srcSpanStartCol thisLoc
2503              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
2504          case (unLoc t, context, mExpectingOCurly) of
2505              -- This case handles a GHC extension to the original H98
2506              -- layout rule...
2507              (ITocurly, _, Just alrLayout) ->
2508                  do setAlrExpectingOCurly Nothing
2509                     let isLet = case alrLayout of
2510                                 ALRLayoutLet -> True
2511                                 _ -> False
2512                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2513                     return t
2514              -- ...and makes this case unnecessary
2515              {-
2516              -- I think our implicit open-curly handling is slightly
2517              -- different to John's, in how it interacts with newlines
2518              -- and "in"
2519              (ITocurly, _, Just _) ->
2520                  do setAlrExpectingOCurly Nothing
2521                     setNextToken t
2522                     lexTokenAlr
2523              -}
2524              (_, ALRLayout _ col : _ls, Just expectingOCurly)
2525               | (thisCol > col) ||
2526                 (thisCol == col &&
2527                  isNonDecreasingIndentation expectingOCurly) ->
2528                  do setAlrExpectingOCurly Nothing
2529                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2530                     setNextToken t
2531                     return (L thisLoc ITocurly)
2532               | otherwise ->
2533                  do setAlrExpectingOCurly Nothing
2534                     setPendingImplicitTokens [L lastLoc ITccurly]
2535                     setNextToken t
2536                     return (L lastLoc ITocurly)
2537              (_, _, Just expectingOCurly) ->
2538                  do setAlrExpectingOCurly Nothing
2539                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2540                     setNextToken t
2541                     return (L thisLoc ITocurly)
2542              -- We do the [] cases earlier than in the spec, as we
2543              -- have an actual EOF token
2544              (ITeof, ALRLayout _ _ : ls, _) ->
2545                  do setALRContext ls
2546                     setNextToken t
2547                     return (L thisLoc ITccurly)
2548              (ITeof, _, _) ->
2549                  return t
2550              -- the other ITeof case omitted; general case below covers it
2551              (ITin, _, _)
2552               | justClosedExplicitLetBlock ->
2553                  return t
2554              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2555               | newLine ->
2556                  do setPendingImplicitTokens [t]
2557                     setALRContext ls
2558                     return (L thisLoc ITccurly)
2559              -- This next case is to handle a transitional issue:
2560              (ITwhere, ALRLayout _ col : ls, _)
2561               | newLine && thisCol == col && transitional ->
2562                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2563                                (RealSrcSpan thisLoc)
2564                                (transitionalAlternativeLayoutWarning
2565                                     "`where' clause at the same depth as implicit layout block")
2566                     setALRContext ls
2567                     setNextToken t
2568                     -- Note that we use lastLoc, as we may need to close
2569                     -- more layouts, or give a semicolon
2570                     return (L lastLoc ITccurly)
2571              -- This next case is to handle a transitional issue:
2572              (ITvbar, ALRLayout _ col : ls, _)
2573               | newLine && thisCol == col && transitional ->
2574                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2575                                (RealSrcSpan thisLoc)
2576                                (transitionalAlternativeLayoutWarning
2577                                     "`|' at the same depth as implicit layout block")
2578                     setALRContext ls
2579                     setNextToken t
2580                     -- Note that we use lastLoc, as we may need to close
2581                     -- more layouts, or give a semicolon
2582                     return (L lastLoc ITccurly)
2583              (_, ALRLayout _ col : ls, _)
2584               | newLine && thisCol == col ->
2585                  do setNextToken t
2586                     return (L thisLoc ITsemi)
2587               | newLine && thisCol < col ->
2588                  do setALRContext ls
2589                     setNextToken t
2590                     -- Note that we use lastLoc, as we may need to close
2591                     -- more layouts, or give a semicolon
2592                     return (L lastLoc ITccurly)
2593              -- We need to handle close before open, as 'then' is both
2594              -- an open and a close
2595              (u, _, _)
2596               | isALRclose u ->
2597                  case context of
2598                  ALRLayout _ _ : ls ->
2599                      do setALRContext ls
2600                         setNextToken t
2601                         return (L thisLoc ITccurly)
2602                  ALRNoLayout _ isLet : ls ->
2603                      do let ls' = if isALRopen u
2604                                      then ALRNoLayout (containsCommas u) False : ls
2605                                      else ls
2606                         setALRContext ls'
2607                         when isLet $ setJustClosedExplicitLetBlock True
2608                         return t
2609                  [] ->
2610                      do let ls = if isALRopen u
2611                                     then [ALRNoLayout (containsCommas u) False]
2612                                     else []
2613                         setALRContext ls
2614                         -- XXX This is an error in John's code, but
2615                         -- it looks reachable to me at first glance
2616                         return t
2617              (u, _, _)
2618               | isALRopen u ->
2619                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2620                     return t
2621              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2622                  do setALRContext ls
2623                     setPendingImplicitTokens [t]
2624                     return (L thisLoc ITccurly)
2625              (ITin, ALRLayout _ _ : ls, _) ->
2626                  do setALRContext ls
2627                     setNextToken t
2628                     return (L thisLoc ITccurly)
2629              -- the other ITin case omitted; general case below covers it
2630              (ITcomma, ALRLayout _ _ : ls, _)
2631               | topNoLayoutContainsCommas ls ->
2632                  do setALRContext ls
2633                     setNextToken t
2634                     return (L thisLoc ITccurly)
2635              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2636                  do setALRContext ls
2637                     setPendingImplicitTokens [t]
2638                     return (L thisLoc ITccurly)
2639              -- the other ITwhere case omitted; general case below covers it
2640              (_, _, _) -> return t
2641
2642 transitionalAlternativeLayoutWarning :: String -> SDoc
2643 transitionalAlternativeLayoutWarning msg
2644     = text "transitional layout will not be accepted in the future:"
2645    $$ text msg
2646
2647 isALRopen :: Token -> Bool
2648 isALRopen ITcase          = True
2649 isALRopen ITif            = True
2650 isALRopen ITthen          = True
2651 isALRopen IToparen        = True
2652 isALRopen ITobrack        = True
2653 isALRopen ITocurly        = True
2654 -- GHC Extensions:
2655 isALRopen IToubxparen     = True
2656 isALRopen ITparenEscape   = True
2657 isALRopen ITparenTyEscape = True
2658 isALRopen _               = False
2659
2660 isALRclose :: Token -> Bool
2661 isALRclose ITof     = True
2662 isALRclose ITthen   = True
2663 isALRclose ITelse   = True
2664 isALRclose ITcparen = True
2665 isALRclose ITcbrack = True
2666 isALRclose ITccurly = True
2667 -- GHC Extensions:
2668 isALRclose ITcubxparen = True
2669 isALRclose _        = False
2670
2671 isNonDecreasingIndentation :: ALRLayout -> Bool
2672 isNonDecreasingIndentation ALRLayoutDo = True
2673 isNonDecreasingIndentation _           = False
2674
2675 containsCommas :: Token -> Bool
2676 containsCommas IToparen = True
2677 containsCommas ITobrack = True
2678 -- John doesn't have {} as containing commas, but records contain them,
2679 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2680 -- (defaultInstallDirs).
2681 containsCommas ITocurly = True
2682 -- GHC Extensions:
2683 containsCommas IToubxparen = True
2684 containsCommas _        = False
2685
2686 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2687 topNoLayoutContainsCommas [] = False
2688 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2689 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2690
2691 lexToken :: P (RealLocated Token)
2692 lexToken = do
2693   inp@(AI loc1 buf) <- getInput
2694   sc <- getLexState
2695   exts <- getExts
2696   case alexScanUser exts inp sc of
2697     AlexEOF -> do
2698         let span = mkRealSrcSpan loc1 loc1
2699         setLastToken span 0
2700         return (L span ITeof)
2701     AlexError (AI loc2 buf) ->
2702         reportLexError loc1 loc2 buf "lexical error"
2703     AlexSkip inp2 _ -> do
2704         setInput inp2
2705         lexToken
2706     AlexToken inp2@(AI end buf2) _ t -> do
2707         setInput inp2
2708         let span = mkRealSrcSpan loc1 end
2709         let bytes = byteDiff buf buf2
2710         span `seq` setLastToken span bytes
2711         lt <- t span buf bytes
2712         case unLoc lt of
2713           ITlineComment _  -> return lt
2714           ITblockComment _ -> return lt
2715           lt' -> do
2716             setLastTk lt'
2717             return lt
2718
2719 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
2720 reportLexError loc1 loc2 buf str
2721   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2722   | otherwise =
2723   let c = fst (nextChar buf)
2724   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2725      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2726      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2727
2728 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
2729 lexTokenStream buf loc dflags = unP go initState
2730     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2731           initState = mkPState dflags' buf loc
2732           go = do
2733             ltok <- lexer False return
2734             case ltok of
2735               L _ ITeof -> return []
2736               _ -> liftM (ltok:) go
2737
2738 linePrags = Map.singleton "line" (begin line_prag2)
2739
2740 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2741                                  ("options_ghc", lex_string_prag IToptions_prag),
2742                                  ("options_haddock", lex_string_prag ITdocOptions),
2743                                  ("language", token ITlanguage_prag),
2744                                  ("include", lex_string_prag ITinclude_prag)])
2745
2746 ignoredPrags = Map.fromList (map ignored pragmas)
2747                where ignored opt = (opt, nested_comment lexToken)
2748                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2749                      options_pragmas = map ("options_" ++) impls
2750                      -- CFILES is a hugs-only thing.
2751                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2752
2753 oneWordPrags = Map.fromList [
2754      ("rules", rulePrag),
2755      ("inline",
2756          strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),
2757      ("inlinable",
2758          strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
2759      ("inlineable",
2760          strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
2761                                     -- Spelling variant
2762      ("notinline",
2763          strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),
2764      ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
2765      ("source", strtoken (\s -> ITsource_prag (SourceText s))),
2766      ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
2767      ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
2768      ("scc", strtoken (\s -> ITscc_prag (SourceText s))),
2769      ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))),
2770      ("core", strtoken (\s -> ITcore_prag (SourceText s))),
2771      ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
2772      ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
2773      ("ann", strtoken (\s -> ITann_prag (SourceText s))),
2774      ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))),
2775      ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))),
2776      ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
2777      ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
2778      ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
2779      ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
2780      ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
2781      ("ctype", strtoken (\s -> ITctype (SourceText s))),
2782      ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
2783      ("column", begin column_prag)
2784      ]
2785
2786 twoWordPrags = Map.fromList([
2787      ("inline conlike",
2788          strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),
2789      ("notinline conlike",
2790          strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),
2791      ("specialize inline",
2792          strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
2793      ("specialize notinline",
2794          strtoken (\s -> (ITspec_inline_prag (SourceText s) False))),
2795      ("vectorize scalar",
2796          strtoken (\s -> ITvect_scalar_prag (SourceText s)))])
2797
2798 dispatch_pragmas :: Map String Action -> Action
2799 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
2800                                        Just found -> found span buf len
2801                                        Nothing -> lexError "unknown pragma"
2802
2803 known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
2804 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
2805  = isKnown && nextCharIsNot curbuf pragmaNameChar
2806     where l = lexemeToString startbuf (byteDiff startbuf curbuf)
2807           isKnown = isJust $ Map.lookup (clean_pragma l) prags
2808           pragmaNameChar c = isAlphaNum c || c == '_'
2809
2810 clean_pragma :: String -> String
2811 clean_pragma prag = canon_ws (map toLower (unprefix prag))
2812                     where unprefix prag' = case stripPrefix "{-#" prag' of
2813                                              Just rest -> rest
2814                                              Nothing -> prag'
2815                           canonical prag' = case prag' of
2816                                               "noinline" -> "notinline"
2817                                               "specialise" -> "specialize"
2818                                               "vectorise" -> "vectorize"
2819                                               "novectorise" -> "novectorize"
2820                                               "constructorlike" -> "conlike"
2821                                               _ -> prag'
2822                           canon_ws s = unwords (map canonical (words s))
2823
2824
2825
2826 {-
2827 %************************************************************************
2828 %*                                                                      *
2829         Helper functions for generating annotations in the parser
2830 %*                                                                      *
2831 %************************************************************************
2832 -}
2833
2834 -- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
2835 --   the AST construct the annotation belongs to; together with the
2836 --   AnnKeywordId, this is the key of the annotation map.
2837 --
2838 --   This type is useful for places in the parser where it is not yet
2839 --   known what SrcSpan an annotation should be added to.  The most
2840 --   common situation is when we are parsing a list: the annotations
2841 --   need to be associated with the AST element that *contains* the
2842 --   list, not the list itself.  'AddAnn' lets us defer adding the
2843 --   annotations until we finish parsing the list and are now parsing
2844 --   the enclosing element; we then apply the 'AddAnn' to associate
2845 --   the annotations.  Another common situation is where a common fragment of
2846 --   the AST has been factored out but there is no separate AST node for
2847 --   this fragment (this occurs in class and data declarations). In this
2848 --   case, the annotation belongs to the parent data declaration.
2849 --
2850 --   The usual way an 'AddAnn' is created is using the 'mj' ("make jump")
2851 --   function, and then it can be discharged using the 'ams' function.
2852 type AddAnn = SrcSpan -> P ()
2853
2854 addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
2855               -> AnnKeywordId     -- The first two parameters are the key
2856               -> SrcSpan          -- The location of the keyword itself
2857               -> P ()
2858 addAnnotation l a v = do
2859   addAnnotationOnly l a v
2860   allocateComments l
2861
2862 addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
2863 addAnnotationOnly l a v = P $ \s -> POk s {
2864   annotations = ((l,a), [v]) : annotations s
2865   } ()
2866
2867 -- |Given a location and a list of AddAnn, apply them all to the location.
2868 addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
2869 addAnnsAt loc anns = mapM_ (\a -> a loc) anns
2870
2871 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
2872 -- 'AddAnn' values for the opening and closing bordering on the start
2873 -- and end of the span
2874 mkParensApiAnn :: SrcSpan -> [AddAnn]
2875 mkParensApiAnn (UnhelpfulSpan _)  = []
2876 mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
2877   where
2878     mj a l = (\s -> addAnnotation s a l)
2879     f = srcSpanFile ss
2880     sl = srcSpanStartLine ss
2881     sc = srcSpanStartCol ss
2882     el = srcSpanEndLine ss
2883     ec = srcSpanEndCol ss
2884     lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
2885     lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
2886
2887 -- | Move the annotations and comments belonging to the @old@ span to the @new@
2888 --   one.
2889 moveAnnotations :: SrcSpan -> SrcSpan -> P ()
2890 moveAnnotations old new = P $ \s ->
2891   let
2892     updateAnn ((l,a),v)
2893       | l == old = ((new,a),v)
2894       | otherwise = ((l,a),v)
2895     updateComment (l,c)
2896       | l == old = (new,c)
2897       | otherwise = (l,c)
2898   in
2899     POk s {
2900        annotations = map updateAnn (annotations s)
2901      , annotations_comments = map updateComment (annotations_comments s)
2902      } ()
2903
2904 queueComment :: Located Token -> P()
2905 queueComment c = P $ \s -> POk s {
2906   comment_q = commentToAnnotation c : comment_q s
2907   } ()
2908
2909 -- | Go through the @comment_q@ in @PState@ and remove all comments
2910 -- that belong within the given span
2911 allocateComments :: SrcSpan -> P ()
2912 allocateComments ss = P $ \s ->
2913   let
2914     (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
2915     (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
2916     comment_q' = before ++ after
2917     newAnns = if null middle then []
2918                              else [(ss,middle)]
2919   in
2920     POk s {
2921        comment_q = comment_q'
2922      , annotations_comments = newAnns ++ (annotations_comments s)
2923      } ()
2924
2925 commentToAnnotation :: Located Token -> Located AnnotationComment
2926 commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
2927 commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)
2928 commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
2929 commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)
2930 commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)
2931 commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)
2932 commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)
2933 commentToAnnotation _                           = panic "commentToAnnotation"
2934
2935 -- ---------------------------------------------------------------------
2936
2937 isComment :: Token -> Bool
2938 isComment (ITlineComment     _)   = True
2939 isComment (ITblockComment    _)   = True
2940 isComment _ = False
2941
2942 isDocComment :: Token -> Bool
2943 isDocComment (ITdocCommentNext  _)   = True
2944 isDocComment (ITdocCommentPrev  _)   = True
2945 isDocComment (ITdocCommentNamed _)   = True
2946 isDocComment (ITdocSection      _ _) = True
2947 isDocComment (ITdocOptions      _)   = True
2948 isDocComment _ = False
2949
2950 {- Note [Warnings in code generated by Alex]
2951
2952 We add the following warning suppression flags to all code generated by Alex:
2953
2954 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
2955 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
2956 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
2957 {-# OPTIONS_GHC -fno-warn-tabs #-}
2958 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2959
2960 Without these flags, current versions of Alex will generate code that is not
2961 warning free. Note that this is the result of Alex' internals, not of the way
2962 we have written our (Lexer).x files.
2963
2964 As always, we need code to be warning free when validating with -Werror.
2965
2966 The list of flags is as short as possible (at the time of writing), to try to
2967 avoid suppressing warnings for bugs in our own code.
2968
2969 TODO. Reevaluate this situation once Alex >3.1.4 is released. Hopefully you
2970 can remove these flags from all (Lexer).x files in the repository, and also
2971 delete this Note. Don't forget to update aclocal.m4, and send a HEADS UP
2972 message to ghc-devs.
2973
2974 The first release of Alex after 3.1.4 will either suppress all warnings itself
2975 [1] (bad), or most warnings will be fixed and only a few select ones will be
2976 suppressed by default [2] (better).
2977
2978 [1] https://github.com/simonmar/alex/commit/1eefcde22ba1bb9b51d523814415714e20f0761e
2979 [2] https://github.com/simonmar/alex/pull/69
2980 -}
2981 }