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