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