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