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