Lexer: delete dead code for binary character literals
[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                    -- 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
591   | ITequal
592   | ITlam
593   | ITlcase
594   | ITvbar
595   | ITlarrow
596   | ITrarrow
597   | ITat
598   | ITtilde
599   | ITtildehsh
600   | ITdarrow
601   | ITminus
602   | ITbang
603   | ITstar
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                --  -<
677   | ITrarrowtail                --  >-
678   | ITLarrowtail                --  -<<
679   | ITRarrowtail                --  >>-
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,        xbit ExplicitForallBit .|.
737                                               xbit InRulePragBit),
738          ( "mdo",            ITmdo,           xbit RecursiveDoBit),
739              -- See Note [Lexing type pseudo-keywords]
740          ( "family",         ITfamily,        0 ),
741          ( "role",           ITrole,          0 ),
742          ( "pattern",        ITpattern,       xbit PatternSynonymsBit),
743          ( "static",         ITstatic,        0 ),
744          ( "group",          ITgroup,         xbit TransformComprehensionsBit),
745          ( "by",             ITby,            xbit TransformComprehensionsBit),
746          ( "using",          ITusing,         xbit TransformComprehensionsBit),
747
748          ( "foreign",        ITforeign,       xbit FfiBit),
749          ( "export",         ITexport,        xbit FfiBit),
750          ( "label",          ITlabel,         xbit FfiBit),
751          ( "dynamic",        ITdynamic,       xbit FfiBit),
752          ( "safe",           ITsafe,          xbit FfiBit .|.
753                                               xbit SafeHaskellBit),
754          ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),
755          ( "unsafe",         ITunsafe,        xbit FfiBit),
756          ( "stdcall",        ITstdcallconv,   xbit FfiBit),
757          ( "ccall",          ITccallconv,     xbit FfiBit),
758          ( "capi",           ITcapiconv,      xbit CApiFfiBit),
759          ( "prim",           ITprimcallconv,  xbit FfiBit),
760          ( "javascript",     ITjavascriptcallconv, xbit FfiBit),
761
762          ( "rec",            ITrec,           xbit ArrowsBit .|.
763                                               xbit RecursiveDoBit),
764          ( "proc",           ITproc,          xbit ArrowsBit)
765      ]
766
767 {-----------------------------------
768 Note [Lexing type pseudo-keywords]
769 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
770
771 One might think that we wish to treat 'family' and 'role' as regular old
772 varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.
773 But, there is no need to do so. These pseudo-keywords are not stolen syntax:
774 they are only used after the keyword 'type' at the top-level, where varids are
775 not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that
776 type families and role annotations are never declared without their extensions
777 on. In fact, by unconditionally lexing these pseudo-keywords as special, we
778 can get better error messages.
779
780 Also, note that these are included in the `varid` production in the parser --
781 a key detail to make all this work.
782 -------------------------------------}
783
784 reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool)
785 reservedSymsFM = listToUFM $
786     map (\ (x,y,z) -> (mkFastString x,(y,z)))
787       [ ("..",  ITdotdot,   always)
788         -- (:) is a reserved op, meaning only list cons
789        ,(":",   ITcolon,    always)
790        ,("::",  ITdcolon,   always)
791        ,("=",   ITequal,    always)
792        ,("\\",  ITlam,      always)
793        ,("|",   ITvbar,     always)
794        ,("<-",  ITlarrow,   always)
795        ,("->",  ITrarrow,   always)
796        ,("@",   ITat,       always)
797        ,("~",   ITtilde,    always)
798        ,("~#",  ITtildehsh, magicHashEnabled)
799        ,("=>",  ITdarrow,   always)
800        ,("-",   ITminus,    always)
801        ,("!",   ITbang,     always)
802
803         -- For data T (a::*) = MkT
804        ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i)
805         -- For 'forall a . t'
806        ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
807
808        ,("-<",  ITlarrowtail, arrowsEnabled)
809        ,(">-",  ITrarrowtail, arrowsEnabled)
810        ,("-<<", ITLarrowtail, arrowsEnabled)
811        ,(">>-", ITRarrowtail, arrowsEnabled)
812
813        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
814        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
815        ,("∀",   ITforall, unicodeSyntaxEnabled)
816        ,("→",   ITrarrow, unicodeSyntaxEnabled)
817        ,("←",   ITlarrow, unicodeSyntaxEnabled)
818
819        ,("⤙",   ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
820        ,("⤚",   ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
821        ,("⤛",   ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
822        ,("⤜",   ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
823
824        ,("★", ITstar, unicodeSyntaxEnabled)
825
826         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
827         -- form part of a large operator.  This would let us have a better
828         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
829        ]
830
831 -- -----------------------------------------------------------------------------
832 -- Lexer actions
833
834 type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
835
836 special :: Token -> Action
837 special tok span _buf _len = return (L span tok)
838
839 token, layout_token :: Token -> Action
840 token t span _buf _len = return (L span t)
841 layout_token t span _buf _len = pushLexState layout >> return (L span t)
842
843 idtoken :: (StringBuffer -> Int -> Token) -> Action
844 idtoken f span buf len = return (L span $! (f buf len))
845
846 skip_one_varid :: (FastString -> Token) -> Action
847 skip_one_varid f span buf len
848   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
849
850 skip_two_varid :: (FastString -> Token) -> Action
851 skip_two_varid f span buf len
852   = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))
853
854 strtoken :: (String -> Token) -> Action
855 strtoken f span buf len =
856   return (L span $! (f $! lexemeToString buf len))
857
858 init_strtoken :: Int -> (String -> Token) -> Action
859 -- like strtoken, but drops the last N character(s)
860 init_strtoken drop f span buf len =
861   return (L span $! (f $! lexemeToString buf (len-drop)))
862
863 begin :: Int -> Action
864 begin code _span _str _len = do pushLexState code; lexToken
865
866 pop :: Action
867 pop _span _buf _len = do _ <- popLexState
868                          lexToken
869
870 hopefully_open_brace :: Action
871 hopefully_open_brace span buf len
872  = do relaxed <- extension relaxedLayout
873       ctx <- getContext
874       (AI l _) <- getInput
875       let offset = srcLocCol l
876           isOK = relaxed ||
877                  case ctx of
878                  Layout prev_off : _ -> prev_off < offset
879                  _                   -> True
880       if isOK then pop_and open_brace span buf len
881               else failSpanMsgP (RealSrcSpan span) (text "Missing block")
882
883 pop_and :: Action -> Action
884 pop_and act span buf len = do _ <- popLexState
885                               act span buf len
886
887 {-# INLINE nextCharIs #-}
888 nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
889 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
890
891 {-# INLINE nextCharIsNot #-}
892 nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool
893 nextCharIsNot buf p = not (nextCharIs buf p)
894
895 notFollowedBy :: Char -> AlexAccPred ExtsBitmap
896 notFollowedBy char _ _ _ (AI _ buf)
897   = nextCharIsNot buf (== char)
898
899 notFollowedBySymbol :: AlexAccPred ExtsBitmap
900 notFollowedBySymbol _ _ _ (AI _ buf)
901   = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")
902
903 -- We must reject doc comments as being ordinary comments everywhere.
904 -- In some cases the doc comment will be selected as the lexeme due to
905 -- maximal munch, but not always, because the nested comment rule is
906 -- valid in all states, but the doc-comment rules are only valid in
907 -- the non-layout states.
908 isNormalComment :: AlexAccPred ExtsBitmap
909 isNormalComment bits _ _ (AI _ buf)
910   | haddockEnabled bits = notFollowedByDocOrPragma
911   | otherwise           = nextCharIsNot buf (== '#')
912   where
913     notFollowedByDocOrPragma
914        = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))
915
916 afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool
917 afterOptionalSpace buf p
918     = if nextCharIs buf (== ' ')
919       then p (snd (nextChar buf))
920       else p buf
921
922 atEOL :: AlexAccPred ExtsBitmap
923 atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
924
925 ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
926 ifExtension pred bits _ _ _ = pred bits
927
928 multiline_doc_comment :: Action
929 multiline_doc_comment span buf _len = withLexedDocType (worker "")
930   where
931     worker commentAcc input docType oneLine = case alexGetChar' input of
932       Just ('\n', input')
933         | oneLine -> docCommentEnd input commentAcc docType buf span
934         | otherwise -> case checkIfCommentLine input' of
935           Just input -> worker ('\n':commentAcc) input docType False
936           Nothing -> docCommentEnd input commentAcc docType buf span
937       Just (c, input) -> worker (c:commentAcc) input docType oneLine
938       Nothing -> docCommentEnd input commentAcc docType buf span
939
940     checkIfCommentLine input = check (dropNonNewlineSpace input)
941       where
942         check input = case alexGetChar' input of
943           Just ('-', input) -> case alexGetChar' input of
944             Just ('-', input) -> case alexGetChar' input of
945               Just (c, _) | c /= '-' -> Just input
946               _ -> Nothing
947             _ -> Nothing
948           _ -> Nothing
949
950         dropNonNewlineSpace input = case alexGetChar' input of
951           Just (c, input')
952             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
953             | otherwise -> input
954           Nothing -> input
955
956 lineCommentToken :: Action
957 lineCommentToken span buf len = do
958   b <- extension rawTokenStreamEnabled
959   if b then strtoken ITlineComment span buf len else lexToken
960
961 {-
962   nested comments require traversing by hand, they can't be parsed
963   using regular expressions.
964 -}
965 nested_comment :: P (RealLocated Token) -> Action
966 nested_comment cont span buf len = do
967   input <- getInput
968   go (reverse $ lexemeToString buf len) (1::Int) input
969   where
970     go commentAcc 0 input = do
971       setInput input
972       b <- extension rawTokenStreamEnabled
973       if b
974         then docCommentEnd input commentAcc ITblockComment buf span
975         else cont
976     go commentAcc n input = case alexGetChar' input of
977       Nothing -> errBrace input span
978       Just ('-',input) -> case alexGetChar' input of
979         Nothing  -> errBrace input span
980         Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'
981         Just (_,_)          -> go ('-':commentAcc) n input
982       Just ('\123',input) -> case alexGetChar' input of  -- '{' char
983         Nothing  -> errBrace input span
984         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
985         Just (_,_)       -> go ('\123':commentAcc) n input
986       Just (c,input) -> go (c:commentAcc) n input
987
988 nested_doc_comment :: Action
989 nested_doc_comment span buf _len = withLexedDocType (go "")
990   where
991     go commentAcc input docType _ = case alexGetChar' input of
992       Nothing -> errBrace input span
993       Just ('-',input) -> case alexGetChar' input of
994         Nothing -> errBrace input span
995         Just ('\125',input) ->
996           docCommentEnd input commentAcc docType buf span
997         Just (_,_) -> go ('-':commentAcc) input docType False
998       Just ('\123', input) -> case alexGetChar' input of
999         Nothing  -> errBrace input span
1000         Just ('-',input) -> do
1001           setInput input
1002           let cont = do input <- getInput; go commentAcc input docType False
1003           nested_comment cont span buf _len
1004         Just (_,_) -> go ('\123':commentAcc) input docType False
1005       Just (c,input) -> go (c:commentAcc) input docType False
1006
1007 withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
1008                  -> P (RealLocated Token)
1009 withLexedDocType lexDocComment = do
1010   input@(AI _ buf) <- getInput
1011   case prevChar buf ' ' of
1012     '|' -> lexDocComment input ITdocCommentNext False
1013     '^' -> lexDocComment input ITdocCommentPrev False
1014     '$' -> lexDocComment input ITdocCommentNamed True
1015     '*' -> lexDocSection 1 input
1016     '#' -> lexDocComment input ITdocOptionsOld False
1017     _ -> panic "withLexedDocType: Bad doc type"
1018  where
1019     lexDocSection n input = case alexGetChar' input of
1020       Just ('*', input) -> lexDocSection (n+1) input
1021       Just (_,   _)     -> lexDocComment input (ITdocSection n) True
1022       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
1023
1024 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
1025 -- off again at the end of the pragma.
1026 rulePrag :: Action
1027 rulePrag span buf len = do
1028   setExts (.|. xbit InRulePragBit)
1029   let !src = lexemeToString buf len
1030   return (L span (ITrules_prag src))
1031
1032 endPrag :: Action
1033 endPrag span _buf _len = do
1034   setExts (.&. complement (xbit InRulePragBit))
1035   return (L span ITclose_prag)
1036
1037 -- docCommentEnd
1038 -------------------------------------------------------------------------------
1039 -- This function is quite tricky. We can't just return a new token, we also
1040 -- need to update the state of the parser. Why? Because the token is longer
1041 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
1042 -- it writes the wrong token length to the parser state. This function is
1043 -- called afterwards, so it can just update the state.
1044
1045 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
1046                  RealSrcSpan -> P (RealLocated Token)
1047 docCommentEnd input commentAcc docType buf span = do
1048   setInput input
1049   let (AI loc nextBuf) = input
1050       comment = reverse commentAcc
1051       span' = mkRealSrcSpan (realSrcSpanStart span) loc
1052       last_len = byteDiff buf nextBuf
1053
1054   span `seq` setLastToken span' last_len
1055   return (L span' (docType comment))
1056
1057 errBrace :: AlexInput -> RealSrcSpan -> P a
1058 errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
1059
1060 open_brace, close_brace :: Action
1061 open_brace span _str _len = do
1062   ctx <- getContext
1063   setContext (NoLayout:ctx)
1064   return (L span ITocurly)
1065 close_brace span _str _len = do
1066   popContext
1067   return (L span ITccurly)
1068
1069 qvarid, qconid :: StringBuffer -> Int -> Token
1070 qvarid buf len = ITqvarid $! splitQualName buf len False
1071 qconid buf len = ITqconid $! splitQualName buf len False
1072
1073 splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)
1074 -- takes a StringBuffer and a length, and returns the module name
1075 -- and identifier parts of a qualified name.  Splits at the *last* dot,
1076 -- because of hierarchical module names.
1077 splitQualName orig_buf len parens = split orig_buf orig_buf
1078   where
1079     split buf dot_buf
1080         | orig_buf `byteDiff` buf >= len  = done dot_buf
1081         | c == '.'                        = found_dot buf'
1082         | otherwise                       = split buf' dot_buf
1083       where
1084        (c,buf') = nextChar buf
1085
1086     -- careful, we might get names like M....
1087     -- so, if the character after the dot is not upper-case, this is
1088     -- the end of the qualifier part.
1089     found_dot buf -- buf points after the '.'
1090         | isUpper c    = split buf' buf
1091         | otherwise    = done buf
1092       where
1093        (c,buf') = nextChar buf
1094
1095     done dot_buf =
1096         (lexemeToFastString orig_buf (qual_size - 1),
1097          if parens -- Prelude.(+)
1098             then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)
1099             else lexemeToFastString dot_buf (len - qual_size))
1100       where
1101         qual_size = orig_buf `byteDiff` dot_buf
1102
1103 varid :: Action
1104 varid span buf len =
1105   case lookupUFM reservedWordsFM fs of
1106     Just (ITcase, _) -> do
1107       lambdaCase <- extension lambdaCaseEnabled
1108       keyword <- if lambdaCase
1109                  then do
1110                    lastTk <- getLastTk
1111                    return $ case lastTk of
1112                      Just ITlam -> ITlcase
1113                      _          -> ITcase
1114                  else
1115                    return ITcase
1116       maybe_layout keyword
1117       return $ L span keyword
1118     Just (ITstatic, _) -> do
1119       flags <- getDynFlags
1120       if xopt Opt_StaticPointers flags
1121         then return $ L span ITstatic
1122         else return $ L span $ ITvarid fs
1123     Just (keyword, 0) -> do
1124       maybe_layout keyword
1125       return $ L span keyword
1126     Just (keyword, exts) -> do
1127       extsEnabled <- extension $ \i -> exts .&. i /= 0
1128       if extsEnabled
1129         then do
1130           maybe_layout keyword
1131           return $ L span keyword
1132         else
1133           return $ L span $ ITvarid fs
1134     Nothing ->
1135       return $ L span $ ITvarid fs
1136   where
1137     !fs = lexemeToFastString buf len
1138
1139 conid :: StringBuffer -> Int -> Token
1140 conid buf len = ITconid $! lexemeToFastString buf len
1141
1142 qvarsym, qconsym :: StringBuffer -> Int -> Token
1143 qvarsym buf len = ITqvarsym $! splitQualName buf len False
1144 qconsym buf len = ITqconsym $! splitQualName buf len False
1145
1146 varsym, consym :: Action
1147 varsym = sym ITvarsym
1148 consym = sym ITconsym
1149
1150 sym :: (FastString -> Token) -> Action
1151 sym con span buf len =
1152   case lookupUFM reservedSymsFM fs of
1153     Just (keyword, exts) -> do
1154       extsEnabled <- extension exts
1155       let !tk | extsEnabled = keyword
1156               | otherwise   = con fs
1157       return $ L span tk
1158     Nothing ->
1159       return $ L span $! con fs
1160   where
1161     !fs = lexemeToFastString buf len
1162
1163 -- Variations on the integral numeric literal.
1164 tok_integral :: (String -> Integer -> Token)
1165              -> (Integer -> Integer)
1166              -> Int -> Int
1167              -> (Integer, (Char -> Int))
1168              -> Action
1169 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
1170  = return $ L span $ itint (lexemeToString buf len)
1171        $! transint $ parseUnsignedInteger
1172        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
1173
1174 -- some conveniences for use with tok_integral
1175 tok_num :: (Integer -> Integer)
1176         -> Int -> Int
1177         -> (Integer, (Char->Int)) -> Action
1178 tok_num = tok_integral ITinteger
1179 tok_primint :: (Integer -> Integer)
1180             -> Int -> Int
1181             -> (Integer, (Char->Int)) -> Action
1182 tok_primint = tok_integral ITprimint
1183 tok_primword :: Int -> Int
1184              -> (Integer, (Char->Int)) -> Action
1185 tok_primword = tok_integral ITprimword positive
1186 positive, negative :: (Integer -> Integer)
1187 positive = id
1188 negative = negate
1189 decimal, octal, hexadecimal :: (Integer, Char -> Int)
1190 decimal = (10,octDecDigit)
1191 binary = (2,octDecDigit)
1192 octal = (8,octDecDigit)
1193 hexadecimal = (16,hexDigit)
1194
1195 -- readRational can understand negative rationals, exponents, everything.
1196 tok_float, tok_primfloat, tok_primdouble :: String -> Token
1197 tok_float        str = ITrational   $! readFractionalLit str
1198 tok_primfloat    str = ITprimfloat  $! readFractionalLit str
1199 tok_primdouble   str = ITprimdouble $! readFractionalLit str
1200
1201 readFractionalLit :: String -> FractionalLit
1202 readFractionalLit str = (FL $! str) $! readRational str
1203
1204 -- -----------------------------------------------------------------------------
1205 -- Layout processing
1206
1207 -- we're at the first token on a line, insert layout tokens if necessary
1208 do_bol :: Action
1209 do_bol span _str _len = do
1210         pos <- getOffside
1211         case pos of
1212             LT -> do
1213                 --trace "layout: inserting '}'" $ do
1214                 popContext
1215                 -- do NOT pop the lex state, we might have a ';' to insert
1216                 return (L span ITvccurly)
1217             EQ -> do
1218                 --trace "layout: inserting ';'" $ do
1219                 _ <- popLexState
1220                 return (L span ITsemi)
1221             GT -> do
1222                 _ <- popLexState
1223                 lexToken
1224
1225 -- certain keywords put us in the "layout" state, where we might
1226 -- add an opening curly brace.
1227 maybe_layout :: Token -> P ()
1228 maybe_layout t = do -- If the alternative layout rule is enabled then
1229                     -- we never create an implicit layout context here.
1230                     -- Layout is handled XXX instead.
1231                     -- The code for closing implicit contexts, or
1232                     -- inserting implicit semi-colons, is therefore
1233                     -- irrelevant as it only applies in an implicit
1234                     -- context.
1235                     alr <- extension alternativeLayoutRule
1236                     unless alr $ f t
1237     where f ITdo    = pushLexState layout_do
1238           f ITmdo   = pushLexState layout_do
1239           f ITof    = pushLexState layout
1240           f ITlcase = pushLexState layout
1241           f ITlet   = pushLexState layout
1242           f ITwhere = pushLexState layout
1243           f ITrec   = pushLexState layout
1244           f ITif    = pushLexState layout_if
1245           f _       = return ()
1246
1247 -- Pushing a new implicit layout context.  If the indentation of the
1248 -- next token is not greater than the previous layout context, then
1249 -- Haskell 98 says that the new layout context should be empty; that is
1250 -- the lexer must generate {}.
1251 --
1252 -- We are slightly more lenient than this: when the new context is started
1253 -- by a 'do', then we allow the new context to be at the same indentation as
1254 -- the previous context.  This is what the 'strict' argument is for.
1255 --
1256 new_layout_context :: Bool -> Token -> Action
1257 new_layout_context strict tok span _buf len = do
1258     _ <- popLexState
1259     (AI l _) <- getInput
1260     let offset = srcLocCol l - len
1261     ctx <- getContext
1262     nondecreasing <- extension nondecreasingIndentation
1263     let strict' = strict || not nondecreasing
1264     case ctx of
1265         Layout prev_off : _  |
1266            (strict'     && prev_off >= offset  ||
1267             not strict' && prev_off > offset) -> do
1268                 -- token is indented to the left of the previous context.
1269                 -- we must generate a {} sequence now.
1270                 pushLexState layout_left
1271                 return (L span tok)
1272         _ -> do
1273                 setContext (Layout offset : ctx)
1274                 return (L span tok)
1275
1276 do_layout_left :: Action
1277 do_layout_left span _buf _len = do
1278     _ <- popLexState
1279     pushLexState bol  -- we must be at the start of a line
1280     return (L span ITvccurly)
1281
1282 -- -----------------------------------------------------------------------------
1283 -- LINE pragmas
1284
1285 setLine :: Int -> Action
1286 setLine code span buf len = do
1287   let line = parseUnsignedInteger buf len 10 octDecDigit
1288   setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
1289         -- subtract one: the line number refers to the *following* line
1290   _ <- popLexState
1291   pushLexState code
1292   lexToken
1293
1294 setFile :: Int -> Action
1295 setFile code span buf len = do
1296   let file = mkFastString (go (lexemeToString (stepOn buf) (len-2)))
1297         where go ('\\':c:cs) = c : go cs
1298               go (c:cs)      = c : go cs
1299               go []          = []
1300               -- decode escapes in the filename.  e.g. on Windows
1301               -- when our filenames have backslashes in, gcc seems to
1302               -- escape the backslashes.  One symptom of not doing this
1303               -- is that filenames in error messages look a bit strange:
1304               --   C:\\foo\bar.hs
1305               -- only the first backslash is doubled, because we apply
1306               -- System.FilePath.normalise before printing out
1307               -- filenames and it does not remove duplicate
1308               -- backslashes after the drive letter (should it?).
1309   setAlrLastLoc $ alrInitialLoc file
1310   setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1311   addSrcFile file
1312   _ <- popLexState
1313   pushLexState code
1314   lexToken
1315
1316 alrInitialLoc :: FastString -> RealSrcSpan
1317 alrInitialLoc file = mkRealSrcSpan loc loc
1318     where -- This is a hack to ensure that the first line in a file
1319           -- looks like it is after the initial location:
1320           loc = mkRealSrcLoc file (-1) (-1)
1321
1322 -- -----------------------------------------------------------------------------
1323 -- Options, includes and language pragmas.
1324
1325 lex_string_prag :: (String -> Token) -> Action
1326 lex_string_prag mkTok span _buf _len
1327     = do input <- getInput
1328          start <- getSrcLoc
1329          tok <- go [] input
1330          end <- getSrcLoc
1331          return (L (mkRealSrcSpan start end) tok)
1332     where go acc input
1333               = if isString input "#-}"
1334                    then do setInput input
1335                            return (mkTok (reverse acc))
1336                    else case alexGetChar input of
1337                           Just (c,i) -> go (c:acc) i
1338                           Nothing -> err input
1339           isString _ [] = True
1340           isString i (x:xs)
1341               = case alexGetChar i of
1342                   Just (c,i') | c == x    -> isString i' xs
1343                   _other -> False
1344           err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
1345
1346
1347 -- -----------------------------------------------------------------------------
1348 -- Strings & Chars
1349
1350 -- This stuff is horrible.  I hates it.
1351
1352 lex_string_tok :: Action
1353 lex_string_tok span buf _len = do
1354   tok <- lex_string ""
1355   (AI end bufEnd) <- getInput
1356   let
1357     tok' = case tok of
1358             ITprimstring _ bs -> ITprimstring src bs
1359             ITstring _ s -> ITstring src s
1360             _ -> panic "lex_string_tok"
1361     src = lexemeToString buf (cur bufEnd - cur buf)
1362   return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')
1363
1364 lex_string :: String -> P Token
1365 lex_string s = do
1366   i <- getInput
1367   case alexGetChar' i of
1368     Nothing -> lit_error i
1369
1370     Just ('"',i)  -> do
1371         setInput i
1372         magicHash <- extension magicHashEnabled
1373         if magicHash
1374           then do
1375             i <- getInput
1376             case alexGetChar' i of
1377               Just ('#',i) -> do
1378                    setInput i
1379                    if any (> '\xFF') s
1380                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1381                     else let bs = unsafeMkByteString (reverse s)
1382                          in return (ITprimstring "" bs)
1383               _other ->
1384                 return (ITstring "" (mkFastString (reverse s)))
1385           else
1386                 return (ITstring "" (mkFastString (reverse s)))
1387
1388     Just ('\\',i)
1389         | Just ('&',i) <- next -> do
1390                 setInput i; lex_string s
1391         | Just (c,i) <- next, c <= '\x7f' && is_space c -> do
1392                            -- is_space only works for <= '\x7f' (#3751, #5425)
1393                 setInput i; lex_stringgap s
1394         where next = alexGetChar' i
1395
1396     Just (c, i1) -> do
1397         case c of
1398           '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)
1399           c | isAny c -> do setInput i1; lex_string (c:s)
1400           _other -> lit_error i
1401
1402 lex_stringgap :: String -> P Token
1403 lex_stringgap s = do
1404   i <- getInput
1405   c <- getCharOrFail i
1406   case c of
1407     '\\' -> lex_string s
1408     c | c <= '\x7f' && is_space c -> lex_stringgap s
1409                            -- is_space only works for <= '\x7f' (#3751, #5425)
1410     _other -> lit_error i
1411
1412
1413 lex_char_tok :: Action
1414 -- Here we are basically parsing character literals, such as 'x' or '\n'
1415 -- but, when Template Haskell is on, we additionally spot
1416 -- 'x and ''T, returning ITsimpleQuote and ITtyQuote respectively,
1417 -- but WITHOUT CONSUMING the x or T part  (the parser does that).
1418 -- So we have to do two characters of lookahead: when we see 'x we need to
1419 -- see if there's a trailing quote
1420 lex_char_tok span buf _len = do        -- We've seen '
1421    i1 <- getInput       -- Look ahead to first character
1422    let loc = realSrcSpanStart span
1423    case alexGetChar' i1 of
1424         Nothing -> lit_error  i1
1425
1426         Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''
1427                    setInput i2
1428                    return (L (mkRealSrcSpan loc end2)  ITtyQuote)
1429
1430         Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash
1431                   setInput i2
1432                   lit_ch <- lex_escape
1433                   i3 <- getInput
1434                   mc <- getCharOrFail i3 -- Trailing quote
1435                   if mc == '\'' then finish_char_tok buf loc lit_ch
1436                                 else lit_error i3
1437
1438         Just (c, i2@(AI _end2 _))
1439                 | not (isAny c) -> lit_error i1
1440                 | otherwise ->
1441
1442                 -- We've seen 'x, where x is a valid character
1443                 --  (i.e. not newline etc) but not a quote or backslash
1444            case alexGetChar' i2 of      -- Look ahead one more character
1445                 Just ('\'', i3) -> do   -- We've seen 'x'
1446                         setInput i3
1447                         finish_char_tok buf loc c
1448                 _other -> do            -- We've seen 'x not followed by quote
1449                                         -- (including the possibility of EOF)
1450                                         -- If TH is on, just parse the quote only
1451                         let (AI end _) = i1
1452                         return (L (mkRealSrcSpan loc end) ITsimpleQuote)
1453
1454 finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)
1455 finish_char_tok buf loc ch  -- We've already seen the closing quote
1456                         -- Just need to check for trailing #
1457   = do  magicHash <- extension magicHashEnabled
1458         i@(AI end bufEnd) <- getInput
1459         let src = lexemeToString buf (cur bufEnd - cur buf)
1460         if magicHash then do
1461                 case alexGetChar' i of
1462                         Just ('#',i@(AI end _)) -> do
1463                           setInput i
1464                           return (L (mkRealSrcSpan loc end) (ITprimchar src ch))
1465                         _other ->
1466                           return (L (mkRealSrcSpan loc end) (ITchar src ch))
1467             else do
1468                    return (L (mkRealSrcSpan loc end) (ITchar src ch))
1469
1470 isAny :: Char -> Bool
1471 isAny c | c > '\x7f' = isPrint c
1472         | otherwise  = is_any c
1473
1474 lex_escape :: P Char
1475 lex_escape = do
1476   i0 <- getInput
1477   c <- getCharOrFail i0
1478   case c of
1479         'a'   -> return '\a'
1480         'b'   -> return '\b'
1481         'f'   -> return '\f'
1482         'n'   -> return '\n'
1483         'r'   -> return '\r'
1484         't'   -> return '\t'
1485         'v'   -> return '\v'
1486         '\\'  -> return '\\'
1487         '"'   -> return '\"'
1488         '\''  -> return '\''
1489         '^'   -> do i1 <- getInput
1490                     c <- getCharOrFail i1
1491                     if c >= '@' && c <= '_'
1492                         then return (chr (ord c - ord '@'))
1493                         else lit_error i1
1494
1495         'x'   -> readNum is_hexdigit 16 hexDigit
1496         'o'   -> readNum is_octdigit  8 octDecDigit
1497         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1498
1499         c1 ->  do
1500            i <- getInput
1501            case alexGetChar' i of
1502             Nothing -> lit_error i0
1503             Just (c2,i2) ->
1504               case alexGetChar' i2 of
1505                 Nothing -> do lit_error i0
1506                 Just (c3,i3) ->
1507                    let str = [c1,c2,c3] in
1508                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1509                                      Just rest <- [stripPrefix p str] ] of
1510                           (escape_char,[]):_ -> do
1511                                 setInput i3
1512                                 return escape_char
1513                           (escape_char,_:_):_ -> do
1514                                 setInput i2
1515                                 return escape_char
1516                           [] -> lit_error i0
1517
1518 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1519 readNum is_digit base conv = do
1520   i <- getInput
1521   c <- getCharOrFail i
1522   if is_digit c
1523         then readNum2 is_digit base conv (conv c)
1524         else lit_error i
1525
1526 readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char
1527 readNum2 is_digit base conv i = do
1528   input <- getInput
1529   read i input
1530   where read i input = do
1531           case alexGetChar' input of
1532             Just (c,input') | is_digit c -> do
1533                let i' = i*base + conv c
1534                if i' > 0x10ffff
1535                   then setInput input >> lexError "numeric escape sequence out of range"
1536                   else read i' input'
1537             _other -> do
1538               setInput input; return (chr i)
1539
1540
1541 silly_escape_chars :: [(String, Char)]
1542 silly_escape_chars = [
1543         ("NUL", '\NUL'),
1544         ("SOH", '\SOH'),
1545         ("STX", '\STX'),
1546         ("ETX", '\ETX'),
1547         ("EOT", '\EOT'),
1548         ("ENQ", '\ENQ'),
1549         ("ACK", '\ACK'),
1550         ("BEL", '\BEL'),
1551         ("BS", '\BS'),
1552         ("HT", '\HT'),
1553         ("LF", '\LF'),
1554         ("VT", '\VT'),
1555         ("FF", '\FF'),
1556         ("CR", '\CR'),
1557         ("SO", '\SO'),
1558         ("SI", '\SI'),
1559         ("DLE", '\DLE'),
1560         ("DC1", '\DC1'),
1561         ("DC2", '\DC2'),
1562         ("DC3", '\DC3'),
1563         ("DC4", '\DC4'),
1564         ("NAK", '\NAK'),
1565         ("SYN", '\SYN'),
1566         ("ETB", '\ETB'),
1567         ("CAN", '\CAN'),
1568         ("EM", '\EM'),
1569         ("SUB", '\SUB'),
1570         ("ESC", '\ESC'),
1571         ("FS", '\FS'),
1572         ("GS", '\GS'),
1573         ("RS", '\RS'),
1574         ("US", '\US'),
1575         ("SP", '\SP'),
1576         ("DEL", '\DEL')
1577         ]
1578
1579 -- before calling lit_error, ensure that the current input is pointing to
1580 -- the position of the error in the buffer.  This is so that we can report
1581 -- a correct location to the user, but also so we can detect UTF-8 decoding
1582 -- errors if they occur.
1583 lit_error :: AlexInput -> P a
1584 lit_error i = do setInput i; lexError "lexical error in string/character literal"
1585
1586 getCharOrFail :: AlexInput -> P Char
1587 getCharOrFail i =  do
1588   case alexGetChar' i of
1589         Nothing -> lexError "unexpected end-of-file in string/character literal"
1590         Just (c,i)  -> do setInput i; return c
1591
1592 -- -----------------------------------------------------------------------------
1593 -- QuasiQuote
1594
1595 lex_qquasiquote_tok :: Action
1596 lex_qquasiquote_tok span buf len = do
1597   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
1598   quoteStart <- getSrcLoc
1599   quote <- lex_quasiquote quoteStart ""
1600   end <- getSrcLoc
1601   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1602            (ITqQuasiQuote (qual,
1603                            quoter,
1604                            mkFastString (reverse quote),
1605                            mkRealSrcSpan quoteStart end)))
1606
1607 lex_quasiquote_tok :: Action
1608 lex_quasiquote_tok span buf len = do
1609   let quoter = tail (lexemeToString buf (len - 1))
1610                 -- 'tail' drops the initial '[',
1611                 -- while the -1 drops the trailing '|'
1612   quoteStart <- getSrcLoc
1613   quote <- lex_quasiquote quoteStart ""
1614   end <- getSrcLoc
1615   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1616            (ITquasiQuote (mkFastString quoter,
1617                           mkFastString (reverse quote),
1618                           mkRealSrcSpan quoteStart end)))
1619
1620 lex_quasiquote :: RealSrcLoc -> String -> P String
1621 lex_quasiquote start s = do
1622   i <- getInput
1623   case alexGetChar' i of
1624     Nothing -> quasiquote_error start
1625
1626     -- NB: The string "|]" terminates the quasiquote,
1627     -- with absolutely no escaping. See the extensive
1628     -- discussion on Trac #5348 for why there is no
1629     -- escape handling.
1630     Just ('|',i)
1631         | Just (']',i) <- alexGetChar' i
1632         -> do { setInput i; return s }
1633
1634     Just (c, i) -> do
1635          setInput i; lex_quasiquote start (c : s)
1636
1637 quasiquote_error :: RealSrcLoc -> P a
1638 quasiquote_error start = do
1639   (AI end buf) <- getInput
1640   reportLexError start end buf "unterminated quasiquotation"
1641
1642 -- -----------------------------------------------------------------------------
1643 -- Warnings
1644
1645 warnTab :: Action
1646 warnTab srcspan _buf _len = do
1647     addTabWarning srcspan
1648     lexToken
1649
1650 warnThen :: WarningFlag -> SDoc -> Action -> Action
1651 warnThen option warning action srcspan buf len = do
1652     addWarning option (RealSrcSpan srcspan) warning
1653     action srcspan buf len
1654
1655 -- -----------------------------------------------------------------------------
1656 -- The Parse Monad
1657
1658 data LayoutContext
1659   = NoLayout
1660   | Layout !Int
1661   deriving Show
1662
1663 data ParseResult a
1664   = POk PState a
1665   | PFailed
1666         SrcSpan         -- The start and end of the text span related to
1667                         -- the error.  Might be used in environments which can
1668                         -- show this span, e.g. by highlighting it.
1669         MsgDoc          -- The error message
1670
1671 data PState = PState {
1672         buffer     :: StringBuffer,
1673         dflags     :: DynFlags,
1674         messages   :: Messages,
1675         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file
1676         tab_count  :: !Int,              -- number of tab warnings in the file
1677         last_tk    :: Maybe Token,
1678         last_loc   :: RealSrcSpan, -- pos of previous token
1679         last_len   :: !Int,        -- len of previous token
1680         loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)
1681         extsBitmap :: !ExtsBitmap,    -- bitmap that determines permitted
1682                                    -- extensions
1683         context    :: [LayoutContext],
1684         lex_state  :: [Int],
1685         srcfiles   :: [FastString],
1686         -- Used in the alternative layout rule:
1687         -- These tokens are the next ones to be sent out. They are
1688         -- just blindly emitted, without the rule looking at them again:
1689         alr_pending_implicit_tokens :: [RealLocated Token],
1690         -- This is the next token to be considered or, if it is Nothing,
1691         -- we need to get the next token from the input stream:
1692         alr_next_token :: Maybe (RealLocated Token),
1693         -- This is what we consider to be the location of the last token
1694         -- emitted:
1695         alr_last_loc :: RealSrcSpan,
1696         -- The stack of layout contexts:
1697         alr_context :: [ALRContext],
1698         -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
1699         -- us what sort of layout the '{' will open:
1700         alr_expecting_ocurly :: Maybe ALRLayout,
1701         -- Have we just had the '}' for a let block? If so, than an 'in'
1702         -- token doesn't need to close anything:
1703         alr_justClosedExplicitLetBlock :: Bool,
1704
1705         -- The next three are used to implement Annotations giving the
1706         -- locations of 'noise' tokens in the source, so that users of
1707         -- the GHC API can do source to source conversions.
1708         -- See note [Api annotations] in ApiAnnotation.hs
1709         annotations :: [(ApiAnnKey,[SrcSpan])],
1710         comment_q :: [Located AnnotationComment],
1711         annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
1712      }
1713         -- last_loc and last_len are used when generating error messages,
1714         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1715         -- current token to happyError, we could at least get rid of last_len.
1716         -- Getting rid of last_loc would require finding another way to
1717         -- implement pushCurrentContext (which is only called from one place).
1718
1719 data ALRContext = ALRNoLayout Bool{- does it contain commas? -}
1720                               Bool{- is it a 'let' block? -}
1721                 | ALRLayout ALRLayout Int
1722 data ALRLayout = ALRLayoutLet
1723                | ALRLayoutWhere
1724                | ALRLayoutOf
1725                | ALRLayoutDo
1726
1727 newtype P a = P { unP :: PState -> ParseResult a }
1728
1729 instance Functor P where
1730   fmap = liftM
1731
1732 instance Applicative P where
1733   pure  = return
1734   (<*>) = ap
1735
1736 instance Monad P where
1737   return = returnP
1738   (>>=) = thenP
1739   fail = failP
1740
1741 returnP :: a -> P a
1742 returnP a = a `seq` (P $ \s -> POk s a)
1743
1744 thenP :: P a -> (a -> P b) -> P b
1745 (P m) `thenP` k = P $ \ s ->
1746         case m s of
1747                 POk s1 a         -> (unP (k a)) s1
1748                 PFailed span err -> PFailed span err
1749
1750 failP :: String -> P a
1751 failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1752
1753 failMsgP :: String -> P a
1754 failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1755
1756 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
1757 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
1758
1759 failSpanMsgP :: SrcSpan -> SDoc -> P a
1760 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1761
1762 getPState :: P PState
1763 getPState = P $ \s -> POk s s
1764
1765 instance HasDynFlags P where
1766     getDynFlags = P $ \s -> POk s (dflags s)
1767
1768 withThisPackage :: (PackageKey -> a) -> P a
1769 withThisPackage f
1770  = do pkg <- liftM thisPackage getDynFlags
1771       return $ f pkg
1772
1773 extension :: (ExtsBitmap -> Bool) -> P Bool
1774 extension p = P $ \s -> POk s (p $! extsBitmap s)
1775
1776 getExts :: P ExtsBitmap
1777 getExts = P $ \s -> POk s (extsBitmap s)
1778
1779 setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()
1780 setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
1781
1782 setSrcLoc :: RealSrcLoc -> P ()
1783 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1784
1785 getSrcLoc :: P RealSrcLoc
1786 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1787
1788 addSrcFile :: FastString -> P ()
1789 addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
1790
1791 setLastToken :: RealSrcSpan -> Int -> P ()
1792 setLastToken loc len = P $ \s -> POk s {
1793   last_loc=loc,
1794   last_len=len
1795   } ()
1796
1797 setLastTk :: Token -> P ()
1798 setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
1799
1800 getLastTk :: P (Maybe Token)
1801 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
1802
1803 data AlexInput = AI RealSrcLoc StringBuffer
1804
1805 alexInputPrevChar :: AlexInput -> Char
1806 alexInputPrevChar (AI _ buf) = prevChar buf '\n'
1807
1808 -- backwards compatibility for Alex 2.x
1809 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1810 alexGetChar inp = case alexGetByte inp of
1811                     Nothing    -> Nothing
1812                     Just (b,i) -> c `seq` Just (c,i)
1813                        where c = chr $ fromIntegral b
1814
1815 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
1816 alexGetByte (AI loc s)
1817   | atEnd s   = Nothing
1818   | otherwise = byte `seq` loc' `seq` s' `seq`
1819                 --trace (show (ord c)) $
1820                 Just (byte, (AI loc' s'))
1821   where (c,s') = nextChar s
1822         loc'   = advanceSrcLoc loc c
1823         byte   = fromIntegral $ ord adj_c
1824
1825         non_graphic     = '\x00'
1826         upper           = '\x01'
1827         lower           = '\x02'
1828         digit           = '\x03'
1829         symbol          = '\x04'
1830         space           = '\x05'
1831         other_graphic   = '\x06'
1832         suffix          = '\x07'
1833
1834         adj_c
1835           | c <= '\x06' = non_graphic
1836           | c <= '\x7f' = c
1837           -- Alex doesn't handle Unicode, so when Unicode
1838           -- character is encountered we output these values
1839           -- with the actual character value hidden in the state.
1840           | otherwise =
1841                 -- NB: The logic behind these definitions is also reflected
1842                 -- in basicTypes/Lexeme.hs
1843                 -- Any changes here should likely be reflected there.
1844
1845                 case generalCategory c of
1846                   UppercaseLetter       -> upper
1847                   LowercaseLetter       -> lower
1848                   TitlecaseLetter       -> upper
1849                   ModifierLetter        -> suffix -- see #10196
1850                   OtherLetter           -> lower -- see #1103
1851                   NonSpacingMark        -> other_graphic
1852                   SpacingCombiningMark  -> other_graphic
1853                   EnclosingMark         -> other_graphic
1854                   DecimalNumber         -> digit
1855                   LetterNumber          -> other_graphic
1856                   OtherNumber           -> digit -- see #4373
1857                   ConnectorPunctuation  -> symbol
1858                   DashPunctuation       -> symbol
1859                   OpenPunctuation       -> other_graphic
1860                   ClosePunctuation      -> other_graphic
1861                   InitialQuote          -> other_graphic
1862                   FinalQuote            -> other_graphic
1863                   OtherPunctuation      -> symbol
1864                   MathSymbol            -> symbol
1865                   CurrencySymbol        -> symbol
1866                   ModifierSymbol        -> symbol
1867                   OtherSymbol           -> symbol
1868                   Space                 -> space
1869                   _other                -> non_graphic
1870
1871 -- This version does not squash unicode characters, it is used when
1872 -- lexing strings.
1873 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1874 alexGetChar' (AI loc s)
1875   | atEnd s   = Nothing
1876   | otherwise = c `seq` loc' `seq` s' `seq`
1877                 --trace (show (ord c)) $
1878                 Just (c, (AI loc' s'))
1879   where (c,s') = nextChar s
1880         loc'   = advanceSrcLoc loc c
1881
1882 getInput :: P AlexInput
1883 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
1884
1885 setInput :: AlexInput -> P ()
1886 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
1887
1888 nextIsEOF :: P Bool
1889 nextIsEOF = do
1890   AI _ s <- getInput
1891   return $ atEnd s
1892
1893 pushLexState :: Int -> P ()
1894 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1895
1896 popLexState :: P Int
1897 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1898
1899 getLexState :: P Int
1900 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1901
1902 popNextToken :: P (Maybe (RealLocated Token))
1903 popNextToken
1904     = P $ \s@PState{ alr_next_token = m } ->
1905               POk (s {alr_next_token = Nothing}) m
1906
1907 activeContext :: P Bool
1908 activeContext = do
1909   ctxt <- getALRContext
1910   expc <- getAlrExpectingOCurly
1911   impt <- implicitTokenPending
1912   case (ctxt,expc) of
1913     ([],Nothing) -> return impt
1914     _other       -> return True
1915
1916 setAlrLastLoc :: RealSrcSpan -> P ()
1917 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
1918
1919 getAlrLastLoc :: P RealSrcSpan
1920 getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
1921
1922 getALRContext :: P [ALRContext]
1923 getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
1924
1925 setALRContext :: [ALRContext] -> P ()
1926 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
1927
1928 getJustClosedExplicitLetBlock :: P Bool
1929 getJustClosedExplicitLetBlock
1930  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
1931
1932 setJustClosedExplicitLetBlock :: Bool -> P ()
1933 setJustClosedExplicitLetBlock b
1934  = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
1935
1936 setNextToken :: RealLocated Token -> P ()
1937 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
1938
1939 implicitTokenPending :: P Bool
1940 implicitTokenPending
1941     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
1942               case ts of
1943               [] -> POk s False
1944               _  -> POk s True
1945
1946 popPendingImplicitToken :: P (Maybe (RealLocated Token))
1947 popPendingImplicitToken
1948     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
1949               case ts of
1950               [] -> POk s Nothing
1951               (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
1952
1953 setPendingImplicitTokens :: [RealLocated Token] -> P ()
1954 setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
1955
1956 getAlrExpectingOCurly :: P (Maybe ALRLayout)
1957 getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
1958
1959 setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
1960 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
1961
1962 -- for reasons of efficiency, flags indicating language extensions (eg,
1963 -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap
1964 -- stored in an unboxed Word64
1965 type ExtsBitmap = Word64
1966
1967 xbit :: ExtBits -> ExtsBitmap
1968 xbit = bit . fromEnum
1969
1970 xtest :: ExtBits -> ExtsBitmap -> Bool
1971 xtest ext xmap = testBit xmap (fromEnum ext)
1972
1973 data ExtBits
1974   = FfiBit
1975   | InterruptibleFfiBit
1976   | CApiFfiBit
1977   | ParrBit
1978   | ArrowsBit
1979   | ThBit
1980   | IpBit
1981   | ExplicitForallBit -- the 'forall' keyword and '.' symbol
1982   | BangPatBit -- Tells the parser to understand bang-patterns
1983                -- (doesn't affect the lexer)
1984   | PatternSynonymsBit -- pattern synonyms
1985   | HaddockBit-- Lex and parse Haddock comments
1986   | MagicHashBit -- "#" in both functions and operators
1987   | KindSigsBit -- Kind signatures on type variables
1988   | RecursiveDoBit -- mdo
1989   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
1990   | UnboxedTuplesBit -- (# and #)
1991   | DatatypeContextsBit
1992   | TransformComprehensionsBit
1993   | QqBit -- enable quasiquoting
1994   | InRulePragBit
1995   | RawTokenStreamBit -- producing a token stream with all comments included
1996   | SccProfilingOnBit
1997   | HpcBit
1998   | AlternativeLayoutRuleBit
1999   | RelaxedLayoutBit
2000   | NondecreasingIndentationBit
2001   | SafeHaskellBit
2002   | TraditionalRecordSyntaxBit
2003   | ExplicitNamespacesBit
2004   | LambdaCaseBit
2005   | BinaryLiteralsBit
2006   | NegativeLiteralsBit
2007   deriving Enum
2008
2009
2010 always :: ExtsBitmap -> Bool
2011 always           _     = True
2012 parrEnabled :: ExtsBitmap -> Bool
2013 parrEnabled = xtest ParrBit
2014 arrowsEnabled :: ExtsBitmap -> Bool
2015 arrowsEnabled = xtest ArrowsBit
2016 thEnabled :: ExtsBitmap -> Bool
2017 thEnabled = xtest ThBit
2018 ipEnabled :: ExtsBitmap -> Bool
2019 ipEnabled = xtest IpBit
2020 explicitForallEnabled :: ExtsBitmap -> Bool
2021 explicitForallEnabled = xtest ExplicitForallBit
2022 bangPatEnabled :: ExtsBitmap -> Bool
2023 bangPatEnabled = xtest BangPatBit
2024 haddockEnabled :: ExtsBitmap -> Bool
2025 haddockEnabled = xtest HaddockBit
2026 magicHashEnabled :: ExtsBitmap -> Bool
2027 magicHashEnabled = xtest MagicHashBit
2028 -- kindSigsEnabled :: ExtsBitmap -> Bool
2029 -- kindSigsEnabled = xtest KindSigsBit
2030 unicodeSyntaxEnabled :: ExtsBitmap -> Bool
2031 unicodeSyntaxEnabled = xtest UnicodeSyntaxBit
2032 unboxedTuplesEnabled :: ExtsBitmap -> Bool
2033 unboxedTuplesEnabled = xtest UnboxedTuplesBit
2034 datatypeContextsEnabled :: ExtsBitmap -> Bool
2035 datatypeContextsEnabled = xtest DatatypeContextsBit
2036 qqEnabled :: ExtsBitmap -> Bool
2037 qqEnabled = xtest QqBit
2038 inRulePrag :: ExtsBitmap -> Bool
2039 inRulePrag = xtest InRulePragBit
2040 rawTokenStreamEnabled :: ExtsBitmap -> Bool
2041 rawTokenStreamEnabled = xtest RawTokenStreamBit
2042 alternativeLayoutRule :: ExtsBitmap -> Bool
2043 alternativeLayoutRule = xtest AlternativeLayoutRuleBit
2044 hpcEnabled :: ExtsBitmap -> Bool
2045 hpcEnabled = xtest HpcBit
2046 relaxedLayout :: ExtsBitmap -> Bool
2047 relaxedLayout = xtest RelaxedLayoutBit
2048 nondecreasingIndentation :: ExtsBitmap -> Bool
2049 nondecreasingIndentation = xtest NondecreasingIndentationBit
2050 sccProfilingOn :: ExtsBitmap -> Bool
2051 sccProfilingOn = xtest SccProfilingOnBit
2052 traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool
2053 traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit
2054
2055 explicitNamespacesEnabled :: ExtsBitmap -> Bool
2056 explicitNamespacesEnabled = xtest ExplicitNamespacesBit
2057 lambdaCaseEnabled :: ExtsBitmap -> Bool
2058 lambdaCaseEnabled = xtest LambdaCaseBit
2059 binaryLiteralsEnabled :: ExtsBitmap -> Bool
2060 binaryLiteralsEnabled = xtest BinaryLiteralsBit
2061 negativeLiteralsEnabled :: ExtsBitmap -> Bool
2062 negativeLiteralsEnabled = xtest NegativeLiteralsBit
2063 patternSynonymsEnabled :: ExtsBitmap -> Bool
2064 patternSynonymsEnabled = xtest PatternSynonymsBit
2065
2066 -- PState for parsing options pragmas
2067 --
2068 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2069 pragState dynflags buf loc = (mkPState dynflags buf loc) {
2070                                  lex_state = [bol, option_prags, 0]
2071                              }
2072
2073 -- create a parse state
2074 --
2075 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2076 mkPState flags buf loc =
2077   PState {
2078       buffer        = buf,
2079       dflags        = flags,
2080       messages      = emptyMessages,
2081       tab_first     = Nothing,
2082       tab_count     = 0,
2083       last_tk       = Nothing,
2084       last_loc      = mkRealSrcSpan loc loc,
2085       last_len      = 0,
2086       loc           = loc,
2087       extsBitmap    = bitmap,
2088       context       = [],
2089       lex_state     = [bol, 0],
2090       srcfiles      = [],
2091       alr_pending_implicit_tokens = [],
2092       alr_next_token = Nothing,
2093       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
2094       alr_context = [],
2095       alr_expecting_ocurly = Nothing,
2096       alr_justClosedExplicitLetBlock = False,
2097       annotations = [],
2098       comment_q = [],
2099       annotations_comments = []
2100     }
2101     where
2102       bitmap =     FfiBit                      `setBitIf` xopt Opt_ForeignFunctionInterface flags
2103                .|. InterruptibleFfiBit         `setBitIf` xopt Opt_InterruptibleFFI         flags
2104                .|. CApiFfiBit                  `setBitIf` xopt Opt_CApiFFI                  flags
2105                .|. ParrBit                     `setBitIf` xopt Opt_ParallelArrays           flags
2106                .|. ArrowsBit                   `setBitIf` xopt Opt_Arrows                   flags
2107                .|. ThBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
2108                .|. QqBit                       `setBitIf` xopt Opt_QuasiQuotes              flags
2109                .|. IpBit                       `setBitIf` xopt Opt_ImplicitParams           flags
2110                .|. ExplicitForallBit           `setBitIf` xopt Opt_ExplicitForAll           flags
2111                .|. BangPatBit                  `setBitIf` xopt Opt_BangPatterns             flags
2112                .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                  flags
2113                .|. MagicHashBit                `setBitIf` xopt Opt_MagicHash                flags
2114                .|. KindSigsBit                 `setBitIf` xopt Opt_KindSignatures           flags
2115                .|. RecursiveDoBit              `setBitIf` xopt Opt_RecursiveDo              flags
2116                .|. UnicodeSyntaxBit            `setBitIf` xopt Opt_UnicodeSyntax            flags
2117                .|. UnboxedTuplesBit            `setBitIf` xopt Opt_UnboxedTuples            flags
2118                .|. DatatypeContextsBit         `setBitIf` xopt Opt_DatatypeContexts         flags
2119                .|. TransformComprehensionsBit  `setBitIf` xopt Opt_TransformListComp        flags
2120                .|. TransformComprehensionsBit  `setBitIf` xopt Opt_MonadComprehensions      flags
2121                .|. RawTokenStreamBit           `setBitIf` gopt Opt_KeepRawTokenStream       flags
2122                .|. HpcBit                      `setBitIf` gopt Opt_Hpc                      flags
2123                .|. AlternativeLayoutRuleBit    `setBitIf` xopt Opt_AlternativeLayoutRule    flags
2124                .|. RelaxedLayoutBit            `setBitIf` xopt Opt_RelaxedLayout            flags
2125                .|. SccProfilingOnBit           `setBitIf` gopt Opt_SccProfilingOn           flags
2126                .|. NondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
2127                .|. SafeHaskellBit              `setBitIf` safeImportsOn                     flags
2128                .|. TraditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
2129                .|. ExplicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags
2130                .|. LambdaCaseBit               `setBitIf` xopt Opt_LambdaCase               flags
2131                .|. BinaryLiteralsBit           `setBitIf` xopt Opt_BinaryLiterals           flags
2132                .|. NegativeLiteralsBit         `setBitIf` xopt Opt_NegativeLiterals         flags
2133                .|. PatternSynonymsBit          `setBitIf` xopt Opt_PatternSynonyms          flags
2134       --
2135       setBitIf :: ExtBits -> Bool -> ExtsBitmap
2136       b `setBitIf` cond | cond      = xbit b
2137                         | otherwise = 0
2138
2139 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
2140 addWarning option srcspan warning
2141  = P $ \s@PState{messages=(ws,es), dflags=d} ->
2142        let warning' = mkWarnMsg d srcspan alwaysQualify warning
2143            ws' = if wopt option d then ws `snocBag` warning' else ws
2144        in POk s{messages=(ws', es)} ()
2145
2146 addTabWarning :: RealSrcSpan -> P ()
2147 addTabWarning srcspan
2148  = P $ \s@PState{tab_first=tf, tab_count=tc, dflags=d} ->
2149        let tf' = if isJust tf then tf else Just srcspan
2150            tc' = tc + 1
2151            s' = if wopt Opt_WarnTabs d
2152                 then s{tab_first = tf', tab_count = tc'}
2153                 else s
2154        in POk s' ()
2155
2156 mkTabWarning :: PState -> Maybe ErrMsg
2157 mkTabWarning PState{tab_first=tf, tab_count=tc, dflags=d} =
2158   let middle = if tc == 1
2159         then text ""
2160         else text ", and in" <+> speakNOf (tc - 1) (text "further location")
2161       message = text "Tab character found here"
2162                 <> middle
2163                 <> text "."
2164                 $+$ text "Please use spaces instead."
2165   in fmap (\s -> mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
2166
2167 getMessages :: PState -> Messages
2168 getMessages p@PState{messages=(ws,es)} =
2169   let tabwarning = mkTabWarning p
2170       ws' = maybe ws (`consBag` ws) tabwarning
2171   in (ws', es)
2172
2173 getContext :: P [LayoutContext]
2174 getContext = P $ \s@PState{context=ctx} -> POk s ctx
2175
2176 setContext :: [LayoutContext] -> P ()
2177 setContext ctx = P $ \s -> POk s{context=ctx} ()
2178
2179 popContext :: P ()
2180 popContext = P $ \ s@(PState{ buffer = buf, dflags = flags, context = ctx,
2181                               last_len = len, last_loc = last_loc }) ->
2182   case ctx of
2183         (_:tl) -> POk s{ context = tl } ()
2184         []     -> PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len)
2185
2186 -- Push a new layout context at the indentation of the last token read.
2187 -- This is only used at the outer level of a module when the 'module'
2188 -- keyword is missing.
2189 pushCurrentContext :: P ()
2190 pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } ->
2191     POk s{context = Layout (srcSpanStartCol loc) : ctx} ()
2192
2193 getOffside :: P Ordering
2194 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
2195                 let offs = srcSpanStartCol loc in
2196                 let ord = case stk of
2197                         (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
2198                                         compare offs n
2199                         _            -> GT
2200                 in POk s ord
2201
2202 -- ---------------------------------------------------------------------------
2203 -- Construct a parse error
2204
2205 srcParseErr
2206   :: DynFlags
2207   -> StringBuffer       -- current buffer (placed just after the last token)
2208   -> Int                -- length of the previous token
2209   -> MsgDoc
2210 srcParseErr dflags buf len
2211   = if null token
2212          then ptext (sLit "parse error (possibly incorrect indentation or mismatched brackets)")
2213          else ptext (sLit "parse error on input") <+> quotes (text token)
2214               $$ ppWhen (not th_enabled && token == "$") -- #7396
2215                         (text "Perhaps you intended to use TemplateHaskell")
2216               $$ ppWhen (token == "<-")
2217                         (text "Perhaps this statement should be within a 'do' block?")
2218               $$ ppWhen (token == "=")
2219                         (text "Perhaps you need a 'let' in a 'do' block?"
2220                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
2221   where token = lexemeToString (offsetBytes (-len) buf) len
2222         th_enabled = xopt Opt_TemplateHaskell dflags
2223
2224 -- Report a parse failure, giving the span of the previous token as
2225 -- the location of the error.  This is the entry point for errors
2226 -- detected during parsing.
2227 srcParseFail :: P a
2228 srcParseFail = P $ \PState{ buffer = buf, dflags = flags, last_len = len,
2229                             last_loc = last_loc } ->
2230     PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len)
2231
2232 -- A lexical error is reported at a particular position in the source file,
2233 -- not over a token range.
2234 lexError :: String -> P a
2235 lexError str = do
2236   loc <- getSrcLoc
2237   (AI end buf) <- getInput
2238   reportLexError loc end buf str
2239
2240 -- -----------------------------------------------------------------------------
2241 -- This is the top-level function: called from the parser each time a
2242 -- new token is to be read from the input.
2243
2244 lexer :: Bool -> (Located Token -> P a) -> P a
2245 lexer queueComments cont = do
2246   alr <- extension alternativeLayoutRule
2247   let lexTokenFun = if alr then lexTokenAlr else lexToken
2248   (L span tok) <- lexTokenFun
2249   --trace ("token: " ++ show tok) $ do
2250
2251   case tok of
2252     ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
2253     _ -> return ()
2254
2255   if (queueComments && isDocComment tok)
2256     then queueComment (L (RealSrcSpan span) tok)
2257     else return ()
2258
2259   if (queueComments && isComment tok)
2260     then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
2261     else cont (L (RealSrcSpan span) tok)
2262
2263 lexTokenAlr :: P (RealLocated Token)
2264 lexTokenAlr = do mPending <- popPendingImplicitToken
2265                  t <- case mPending of
2266                       Nothing ->
2267                           do mNext <- popNextToken
2268                              t <- case mNext of
2269                                   Nothing -> lexToken
2270                                   Just next -> return next
2271                              alternativeLayoutRuleToken t
2272                       Just t ->
2273                           return t
2274                  setAlrLastLoc (getLoc t)
2275                  case unLoc t of
2276                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2277                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2278                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2279                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2280                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2281                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2282                      _       -> return ()
2283                  return t
2284
2285 alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
2286 alternativeLayoutRuleToken t
2287     = do context <- getALRContext
2288          lastLoc <- getAlrLastLoc
2289          mExpectingOCurly <- getAlrExpectingOCurly
2290          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2291          setJustClosedExplicitLetBlock False
2292          dflags <- getDynFlags
2293          let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
2294              thisLoc = getLoc t
2295              thisCol = srcSpanStartCol thisLoc
2296              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
2297          case (unLoc t, context, mExpectingOCurly) of
2298              -- This case handles a GHC extension to the original H98
2299              -- layout rule...
2300              (ITocurly, _, Just alrLayout) ->
2301                  do setAlrExpectingOCurly Nothing
2302                     let isLet = case alrLayout of
2303                                 ALRLayoutLet -> True
2304                                 _ -> False
2305                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2306                     return t
2307              -- ...and makes this case unnecessary
2308              {-
2309              -- I think our implicit open-curly handling is slightly
2310              -- different to John's, in how it interacts with newlines
2311              -- and "in"
2312              (ITocurly, _, Just _) ->
2313                  do setAlrExpectingOCurly Nothing
2314                     setNextToken t
2315                     lexTokenAlr
2316              -}
2317              (_, ALRLayout _ col : _ls, Just expectingOCurly)
2318               | (thisCol > col) ||
2319                 (thisCol == col &&
2320                  isNonDecreasingIntentation expectingOCurly) ->
2321                  do setAlrExpectingOCurly Nothing
2322                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2323                     setNextToken t
2324                     return (L thisLoc ITocurly)
2325               | otherwise ->
2326                  do setAlrExpectingOCurly Nothing
2327                     setPendingImplicitTokens [L lastLoc ITccurly]
2328                     setNextToken t
2329                     return (L lastLoc ITocurly)
2330              (_, _, Just expectingOCurly) ->
2331                  do setAlrExpectingOCurly Nothing
2332                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2333                     setNextToken t
2334                     return (L thisLoc ITocurly)
2335              -- We do the [] cases earlier than in the spec, as we
2336              -- have an actual EOF token
2337              (ITeof, ALRLayout _ _ : ls, _) ->
2338                  do setALRContext ls
2339                     setNextToken t
2340                     return (L thisLoc ITccurly)
2341              (ITeof, _, _) ->
2342                  return t
2343              -- the other ITeof case omitted; general case below covers it
2344              (ITin, _, _)
2345               | justClosedExplicitLetBlock ->
2346                  return t
2347              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2348               | newLine ->
2349                  do setPendingImplicitTokens [t]
2350                     setALRContext ls
2351                     return (L thisLoc ITccurly)
2352              -- This next case is to handle a transitional issue:
2353              (ITwhere, ALRLayout _ col : ls, _)
2354               | newLine && thisCol == col && transitional ->
2355                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2356                                (RealSrcSpan thisLoc)
2357                                (transitionalAlternativeLayoutWarning
2358                                     "`where' clause at the same depth as implicit layout block")
2359                     setALRContext ls
2360                     setNextToken t
2361                     -- Note that we use lastLoc, as we may need to close
2362                     -- more layouts, or give a semicolon
2363                     return (L lastLoc ITccurly)
2364              -- This next case is to handle a transitional issue:
2365              (ITvbar, ALRLayout _ col : ls, _)
2366               | newLine && thisCol == col && transitional ->
2367                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2368                                (RealSrcSpan thisLoc)
2369                                (transitionalAlternativeLayoutWarning
2370                                     "`|' at the same depth as implicit layout block")
2371                     setALRContext ls
2372                     setNextToken t
2373                     -- Note that we use lastLoc, as we may need to close
2374                     -- more layouts, or give a semicolon
2375                     return (L lastLoc ITccurly)
2376              (_, ALRLayout _ col : ls, _)
2377               | newLine && thisCol == col ->
2378                  do setNextToken t
2379                     return (L thisLoc ITsemi)
2380               | newLine && thisCol < col ->
2381                  do setALRContext ls
2382                     setNextToken t
2383                     -- Note that we use lastLoc, as we may need to close
2384                     -- more layouts, or give a semicolon
2385                     return (L lastLoc ITccurly)
2386              -- We need to handle close before open, as 'then' is both
2387              -- an open and a close
2388              (u, _, _)
2389               | isALRclose u ->
2390                  case context of
2391                  ALRLayout _ _ : ls ->
2392                      do setALRContext ls
2393                         setNextToken t
2394                         return (L thisLoc ITccurly)
2395                  ALRNoLayout _ isLet : ls ->
2396                      do let ls' = if isALRopen u
2397                                      then ALRNoLayout (containsCommas u) False : ls
2398                                      else ls
2399                         setALRContext ls'
2400                         when isLet $ setJustClosedExplicitLetBlock True
2401                         return t
2402                  [] ->
2403                      do let ls = if isALRopen u
2404                                     then [ALRNoLayout (containsCommas u) False]
2405                                     else []
2406                         setALRContext ls
2407                         -- XXX This is an error in John's code, but
2408                         -- it looks reachable to me at first glance
2409                         return t
2410              (u, _, _)
2411               | isALRopen u ->
2412                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2413                     return t
2414              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2415                  do setALRContext ls
2416                     setPendingImplicitTokens [t]
2417                     return (L thisLoc ITccurly)
2418              (ITin, ALRLayout _ _ : ls, _) ->
2419                  do setALRContext ls
2420                     setNextToken t
2421                     return (L thisLoc ITccurly)
2422              -- the other ITin case omitted; general case below covers it
2423              (ITcomma, ALRLayout _ _ : ls, _)
2424               | topNoLayoutContainsCommas ls ->
2425                  do setALRContext ls
2426                     setNextToken t
2427                     return (L thisLoc ITccurly)
2428              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2429                  do setALRContext ls
2430                     setPendingImplicitTokens [t]
2431                     return (L thisLoc ITccurly)
2432              -- the other ITwhere case omitted; general case below covers it
2433              (_, _, _) -> return t
2434
2435 transitionalAlternativeLayoutWarning :: String -> SDoc
2436 transitionalAlternativeLayoutWarning msg
2437     = text "transitional layout will not be accepted in the future:"
2438    $$ text msg
2439
2440 isALRopen :: Token -> Bool
2441 isALRopen ITcase          = True
2442 isALRopen ITif            = True
2443 isALRopen ITthen          = True
2444 isALRopen IToparen        = True
2445 isALRopen ITobrack        = True
2446 isALRopen ITocurly        = True
2447 -- GHC Extensions:
2448 isALRopen IToubxparen     = True
2449 isALRopen ITparenEscape   = True
2450 isALRopen ITparenTyEscape = True
2451 isALRopen _               = False
2452
2453 isALRclose :: Token -> Bool
2454 isALRclose ITof     = True
2455 isALRclose ITthen   = True
2456 isALRclose ITelse   = True
2457 isALRclose ITcparen = True
2458 isALRclose ITcbrack = True
2459 isALRclose ITccurly = True
2460 -- GHC Extensions:
2461 isALRclose ITcubxparen = True
2462 isALRclose _        = False
2463
2464 isNonDecreasingIntentation :: ALRLayout -> Bool
2465 isNonDecreasingIntentation ALRLayoutDo = True
2466 isNonDecreasingIntentation _           = False
2467
2468 containsCommas :: Token -> Bool
2469 containsCommas IToparen = True
2470 containsCommas ITobrack = True
2471 -- John doesn't have {} as containing commas, but records contain them,
2472 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2473 -- (defaultInstallDirs).
2474 containsCommas ITocurly = True
2475 -- GHC Extensions:
2476 containsCommas IToubxparen = True
2477 containsCommas _        = False
2478
2479 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2480 topNoLayoutContainsCommas [] = False
2481 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2482 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2483
2484 lexToken :: P (RealLocated Token)
2485 lexToken = do
2486   inp@(AI loc1 buf) <- getInput
2487   sc <- getLexState
2488   exts <- getExts
2489   case alexScanUser exts inp sc of
2490     AlexEOF -> do
2491         let span = mkRealSrcSpan loc1 loc1
2492         setLastToken span 0
2493         return (L span ITeof)
2494     AlexError (AI loc2 buf) ->
2495         reportLexError loc1 loc2 buf "lexical error"
2496     AlexSkip inp2 _ -> do
2497         setInput inp2
2498         lexToken
2499     AlexToken inp2@(AI end buf2) _ t -> do
2500         setInput inp2
2501         let span = mkRealSrcSpan loc1 end
2502         let bytes = byteDiff buf buf2
2503         span `seq` setLastToken span bytes
2504         lt <- t span buf bytes
2505         case unLoc lt of
2506           ITlineComment _  -> return lt
2507           ITblockComment _ -> return lt
2508           lt' -> do
2509             setLastTk lt'
2510             return lt
2511
2512 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
2513 reportLexError loc1 loc2 buf str
2514   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2515   | otherwise =
2516   let c = fst (nextChar buf)
2517   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2518      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2519      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2520
2521 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
2522 lexTokenStream buf loc dflags = unP go initState
2523     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2524           initState = mkPState dflags' buf loc
2525           go = do
2526             ltok <- lexer False return
2527             case ltok of
2528               L _ ITeof -> return []
2529               _ -> liftM (ltok:) go
2530
2531 linePrags = Map.singleton "line" (begin line_prag2)
2532
2533 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2534                                  ("options_ghc", lex_string_prag IToptions_prag),
2535                                  ("options_haddock", lex_string_prag ITdocOptions),
2536                                  ("language", token ITlanguage_prag),
2537                                  ("include", lex_string_prag ITinclude_prag)])
2538
2539 ignoredPrags = Map.fromList (map ignored pragmas)
2540                where ignored opt = (opt, nested_comment lexToken)
2541                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2542                      options_pragmas = map ("options_" ++) impls
2543                      -- CFILES is a hugs-only thing.
2544                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2545
2546 oneWordPrags = Map.fromList([
2547            ("rules", rulePrag),
2548            ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))),
2549            ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
2550            ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
2551                                           -- Spelling variant
2552            ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))),
2553            ("specialize", strtoken (\s -> ITspec_prag s)),
2554            ("source", strtoken (\s -> ITsource_prag s)),
2555            ("warning", strtoken (\s -> ITwarning_prag s)),
2556            ("deprecated", strtoken (\s -> ITdeprecated_prag s)),
2557            ("scc", strtoken (\s -> ITscc_prag s)),
2558            ("generated", strtoken (\s -> ITgenerated_prag s)),
2559            ("core", strtoken (\s -> ITcore_prag s)),
2560            ("unpack", strtoken (\s -> ITunpack_prag s)),
2561            ("nounpack", strtoken (\s -> ITnounpack_prag s)),
2562            ("ann", strtoken (\s -> ITann_prag s)),
2563            ("vectorize", strtoken (\s -> ITvect_prag s)),
2564            ("novectorize", strtoken (\s -> ITnovect_prag s)),
2565            ("minimal", strtoken (\s -> ITminimal_prag s)),
2566            ("overlaps", strtoken (\s -> IToverlaps_prag s)),
2567            ("overlappable", strtoken (\s -> IToverlappable_prag s)),
2568            ("overlapping", strtoken (\s -> IToverlapping_prag s)),
2569            ("incoherent", strtoken (\s -> ITincoherent_prag s)),
2570            ("ctype", strtoken (\s -> ITctype s))])
2571
2572 twoWordPrags = Map.fromList([
2573      ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))),
2574      ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))),
2575      ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))),
2576      ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))),
2577      ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))])
2578
2579 dispatch_pragmas :: Map String Action -> Action
2580 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
2581                                        Just found -> found span buf len
2582                                        Nothing -> lexError "unknown pragma"
2583
2584 known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
2585 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
2586  = isKnown && nextCharIsNot curbuf pragmaNameChar
2587     where l = lexemeToString startbuf (byteDiff startbuf curbuf)
2588           isKnown = isJust $ Map.lookup (clean_pragma l) prags
2589           pragmaNameChar c = isAlphaNum c || c == '_'
2590
2591 clean_pragma :: String -> String
2592 clean_pragma prag = canon_ws (map toLower (unprefix prag))
2593                     where unprefix prag' = case stripPrefix "{-#" prag' of
2594                                              Just rest -> rest
2595                                              Nothing -> prag'
2596                           canonical prag' = case prag' of
2597                                               "noinline" -> "notinline"
2598                                               "specialise" -> "specialize"
2599                                               "vectorise" -> "vectorize"
2600                                               "novectorise" -> "novectorize"
2601                                               "constructorlike" -> "conlike"
2602                                               _ -> prag'
2603                           canon_ws s = unwords (map canonical (words s))
2604
2605
2606
2607 {-
2608 %************************************************************************
2609 %*                                                                      *
2610         Helper functions for generating annotations in the parser
2611 %*                                                                      *
2612 %************************************************************************
2613 -}
2614
2615 -- |Encapsulated call to addAnnotation, requiring only the SrcSpan of
2616 -- the AST element the annotation belongs to
2617 type AddAnn = (SrcSpan -> P ())
2618
2619 addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
2620 addAnnotation l a v = do
2621   addAnnotationOnly l a v
2622   allocateComments l
2623
2624 addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
2625 addAnnotationOnly l a v = P $ \s -> POk s {
2626   annotations = ((l,a), [v]) : annotations s
2627   } ()
2628
2629 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
2630 -- 'AddAnn' values for the opening and closing bordering on the start
2631 -- and end of the span
2632 mkParensApiAnn :: SrcSpan -> [AddAnn]
2633 mkParensApiAnn (UnhelpfulSpan _)  = []
2634 mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
2635   where
2636     mj a l = (\s -> addAnnotation s a l)
2637     f = srcSpanFile ss
2638     sl = srcSpanStartLine ss
2639     sc = srcSpanStartCol ss
2640     el = srcSpanEndLine ss
2641     ec = srcSpanEndCol ss
2642     lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
2643     lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
2644
2645 queueComment :: Located Token -> P()
2646 queueComment c = P $ \s -> POk s {
2647   comment_q = commentToAnnotation c : comment_q s
2648   } ()
2649
2650 -- | Go through the @comment_q@ in @PState@ and remove all comments
2651 -- that belong within the given span
2652 allocateComments :: SrcSpan -> P ()
2653 allocateComments ss = P $ \s ->
2654   let
2655     (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
2656     (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
2657     comment_q' = before ++ after
2658     newAnns = if null middle then []
2659                              else [(ss,middle)]
2660   in
2661     POk s {
2662        comment_q = comment_q'
2663      , annotations_comments = newAnns ++ (annotations_comments s)
2664      } ()
2665
2666 commentToAnnotation :: Located Token -> Located AnnotationComment
2667 commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
2668 commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)
2669 commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
2670 commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)
2671 commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)
2672 commentToAnnotation (L l (ITdocOptionsOld s))   = L l (AnnDocOptionsOld s)
2673 commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)
2674 commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)
2675 commentToAnnotation _                           = panic "commentToAnnotation"
2676
2677 -- ---------------------------------------------------------------------
2678
2679 isComment :: Token -> Bool
2680 isComment (ITlineComment     _)   = True
2681 isComment (ITblockComment    _)   = True
2682 isComment _ = False
2683
2684 isDocComment :: Token -> Bool
2685 isDocComment (ITdocCommentNext  _)   = True
2686 isDocComment (ITdocCommentPrev  _)   = True
2687 isDocComment (ITdocCommentNamed _)   = True
2688 isDocComment (ITdocSection      _ _) = True
2689 isDocComment (ITdocOptions      _)   = True
2690 isDocComment (ITdocOptionsOld   _)   = True
2691 isDocComment _ = False
2692
2693 {- Note [Warnings in code generated by Alex]
2694
2695 We add the following warning suppression flags to all code generated by Alex:
2696
2697 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
2698 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
2699 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
2700 {-# OPTIONS_GHC -fno-warn-tabs #-}
2701 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2702
2703 Without these flags, current versions of Alex will generate code that is not
2704 warning free. Note that this is the result of Alex' internals, not of the way
2705 we have written our (Lexer).x files.
2706
2707 As always, we need code to be warning free when validating with -Werror.
2708
2709 The list of flags is as short as possible (at the time of writing), to try to
2710 avoid suppressing warnings for bugs in our own code.
2711
2712 TODO. Reevaluate this situation once Alex >3.1.4 is released. Hopefully you
2713 can remove these flags from all (Lexer).x files in the repository, and also
2714 delete this Note. Don't forget to update aclocal.m4, and send a HEADS UP
2715 message to ghc-devs.
2716
2717 The first release of Alex after 3.1.4 will either suppress all warnings itself
2718 [1] (bad), or most warnings will be fixed and only a few select ones will be
2719 suppressed by default [2] (better).
2720
2721 [1] https://github.com/simonmar/alex/commit/1eefcde22ba1bb9b51d523814415714e20f0761e
2722 [2] https://github.com/simonmar/alex/pull/69
2723 -}
2724 }