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