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