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