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