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