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