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