Require a bang pattern when unlifted types are where/let bound; #3182
[ghc.git] / compiler / parser / Lexer.x
1 -----------------------------------------------------------------------------
2 -- (c) The University of Glasgow, 2006
3 --
4 -- GHC's lexer.
5 --
6 -- This is a combination of an Alex-generated lexer from a regex
7 -- definition, with some hand-coded bits.
8 --
9 -- Completely accurate information about token-spans within the source
10 -- file is maintained.  Every token has a start and end SrcLoc attached to it.
11 --
12 -----------------------------------------------------------------------------
13
14 --   ToDo / known bugs:
15 --    - Unicode
16 --    - parsing integers is a bit slow
17 --    - readRational is a bit slow
18 --
19 --   Known bugs, that were also in the previous version:
20 --    - M... should be 3 tokens, not 1.
21 --    - pragma-end should be only valid in a pragma
22
23 --   qualified operator NOTES.
24 --   
25 --   - If M.(+) is a single lexeme, then..
26 --     - Probably (+) should be a single lexeme too, for consistency.
27 --       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.
28 --     - But we have to rule out reserved operators, otherwise (..) becomes
29 --       a different lexeme.
30 --     - Should we therefore also rule out reserved operators in the qualified
31 --       form?  This is quite difficult to achieve.  We don't do it for
32 --       qualified varids.
33
34 {
35 {-# OPTIONS -Wwarn #-}
36 -- The above warning supression flag is a temporary kludge.
37 -- While working on this module you are encouraged to remove it and fix
38 -- any warnings in the module. See
39 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
40 -- for details
41 --
42 -- Note that Alex itself generates code with with some unused bindings and
43 -- without type signatures, so removing the flag might not be possible.
44
45 {-# OPTIONS_GHC -funbox-strict-fields #-}
46
47 module Lexer (
48    Token(..), lexer, pragState, mkPState, PState(..),
49    P(..), ParseResult(..), getSrcLoc, 
50    failLocMsgP, failSpanMsgP, srcParseFail,
51    getMessages,
52    popContext, pushCurrentContext, setLastToken, setSrcLoc,
53    getLexState, popLexState, pushLexState,
54    extension, standaloneDerivingEnabled, bangPatEnabled,
55    addWarning,
56    lexTokenStream
57   ) where
58
59 import Bag
60 import ErrUtils
61 import Outputable
62 import StringBuffer
63 import FastString
64 import FastTypes
65 import SrcLoc
66 import UniqFM
67 import DynFlags
68 import Ctype
69 import Util             ( maybePrefixMatch, readRational )
70
71 import Control.Monad
72 import Data.Bits
73 import Data.Char
74 import Data.Ratio
75 import Debug.Trace
76 }
77
78 $unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
79 $whitechar   = [\ \n\r\f\v $unispace]
80 $white_no_nl = $whitechar # \n
81 $tab         = \t
82
83 $ascdigit  = 0-9
84 $unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
85 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
86 $digit     = [$ascdigit $unidigit]
87
88 $special   = [\(\)\,\;\[\]\`\{\}]
89 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
90 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
91 $symbol    = [$ascsymbol $unisymbol] # [$special \_\:\"\']
92
93 $unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
94 $asclarge  = [A-Z]
95 $large     = [$asclarge $unilarge]
96
97 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
98 $ascsmall  = [a-z]
99 $small     = [$ascsmall $unismall \_]
100
101 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
102 $graphic   = [$small $large $symbol $digit $special $unigraphic \:\"\']
103
104 $octit     = 0-7
105 $hexit     = [$decdigit A-F a-f]
106 $symchar   = [$symbol \:]
107 $nl        = [\n\r]
108 $idchar    = [$small $large $digit \']
109
110 $docsym    = [\| \^ \* \$]
111
112 @varid     = $small $idchar*
113 @conid     = $large $idchar*
114
115 @varsym    = $symbol $symchar*
116 @consym    = \: $symchar*
117
118 @decimal     = $decdigit+
119 @octal       = $octit+
120 @hexadecimal = $hexit+
121 @exponent    = [eE] [\-\+]? @decimal
122
123 -- we support the hierarchical module name extension:
124 @qual = (@conid \.)+
125
126 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
127
128 -- normal signed numerical literals can only be explicitly negative,
129 -- not explicitly positive (contrast @exponent)
130 @negative = \-
131 @signed = @negative ?
132
133 haskell :-
134
135 -- everywhere: skip whitespace and comments
136 $white_no_nl+                           ;
137 $tab+         { warn Opt_WarnTabs (text "Tab character") }
138
139 -- Everywhere: deal with nested comments.  We explicitly rule out
140 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
141 -- (this can happen even though pragmas will normally take precedence due to
142 -- longest-match, because pragmas aren't valid in every state, but comments
143 -- are). We also rule out nested Haddock comments, if the -haddock flag is
144 -- set.
145
146 "{-" / { isNormalComment } { nested_comment lexToken }
147
148 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
149 -- more dashes followed by a symbol should be parsed as a varsym, so we
150 -- have to exclude those.
151
152 -- Since Haddock comments aren't valid in every state, we need to rule them
153 -- out here.  
154
155 -- The following two rules match comments that begin with two dashes, but
156 -- continue with a different character. The rules test that this character
157 -- is not a symbol (in which case we'd have a varsym), and that it's not a
158 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
159 -- have a Haddock comment). The rules then munch the rest of the line.
160
161 "-- " ~[$docsym \#] .* { lineCommentToken }
162 "--" [^$symbol : \ ] .* { lineCommentToken }
163
164 -- Next, match Haddock comments if no -haddock flag
165
166 "-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }
167
168 -- Now, when we've matched comments that begin with 2 dashes and continue
169 -- with a different character, we need to match comments that begin with three
170 -- or more dashes (which clearly can't be Haddock comments). We only need to
171 -- make sure that the first non-dash character isn't a symbol, and munch the
172 -- rest of the line.
173
174 "---"\-* [^$symbol :] .* { lineCommentToken }
175
176 -- Since the previous rules all match dashes followed by at least one
177 -- character, we also need to match a whole line filled with just dashes.
178
179 "--"\-* / { atEOL } { lineCommentToken }
180
181 -- We need this rule since none of the other single line comment rules
182 -- actually match this case.
183
184 "-- " / { atEOL } { lineCommentToken }
185
186 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
187 -- blank lines) until we find a non-whitespace character, then do layout
188 -- processing.
189 --
190 -- One slight wibble here: what if the line begins with {-#? In
191 -- theory, we have to lex the pragma to see if it's one we recognise,
192 -- and if it is, then we backtrack and do_bol, otherwise we treat it
193 -- as a nested comment.  We don't bother with this: if the line begins
194 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
195 <bol> {
196   \n                                    ;
197   ^\# (line)?                           { begin line_prag1 }
198   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
199   ^\# \! .* \n                          ; -- #!, for scripts
200   ()                                    { do_bol }
201 }
202
203 -- after a layout keyword (let, where, do, of), we begin a new layout
204 -- context if the curly brace is missing.
205 -- Careful! This stuff is quite delicate.
206 <layout, layout_do> {
207   \{ / { notFollowedBy '-' }            { pop_and open_brace }
208         -- we might encounter {-# here, but {- has been handled already
209   \n                                    ;
210   ^\# (line)?                           { begin line_prag1 }
211 }
212
213 -- do is treated in a subtly different way, see new_layout_context
214 <layout>    ()                          { new_layout_context True }
215 <layout_do> ()                          { new_layout_context False }
216
217 -- after a new layout context which was found to be to the left of the
218 -- previous context, we have generated a '{' token, and we now need to
219 -- generate a matching '}' token.
220 <layout_left>  ()                       { do_layout_left }
221
222 <0,option_prags> \n                             { begin bol }
223
224 "{-#" $whitechar* (line|LINE) / { notFollowedByPragmaChar }
225                             { begin line_prag2 }
226
227 -- single-line line pragmas, of the form
228 --    # <line> "<file>" <extra-stuff> \n
229 <line_prag1> $decdigit+                 { setLine line_prag1a }
230 <line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }
231 <line_prag1b> .*                        { pop }
232
233 -- Haskell-style line pragmas, of the form
234 --    {-# LINE <line> "<file>" #-}
235 <line_prag2> $decdigit+                 { setLine line_prag2a }
236 <line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }
237 <line_prag2b> "#-}"|"-}"                { pop }
238    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
239    -- with older versions of GHC which generated these.
240
241 <0,option_prags> {
242   "{-#" $whitechar* (RULES|rules)  / { notFollowedByPragmaChar } { rulePrag }
243   "{-#" $whitechar* (INLINE|inline)      / { notFollowedByPragmaChar }
244                     { token (ITinline_prag True) }
245   "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline) / { notFollowedByPragmaChar }
246                                         { token (ITinline_prag False) }
247   "{-#" $whitechar* (INLINE|inline)
248         $whitechar+ (CONLIKE|conlike) / { notFollowedByPragmaChar }
249                                         { token (ITinline_conlike_prag True) }
250   "{-#" $whitechar* (NO(T)?INLINE|no(t?)inline)
251         $whitechar+ (CONLIKE|constructorlike) / { notFollowedByPragmaChar }
252                                         { token (ITinline_conlike_prag False) }
253   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e) / { notFollowedByPragmaChar }
254                                         { token ITspec_prag }
255   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
256         $whitechar+ (INLINE|inline) / { notFollowedByPragmaChar }
257                     { token (ITspec_inline_prag True) }
258   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
259         $whitechar+ (NO(T?)INLINE|no(t?)inline) / { notFollowedByPragmaChar }
260                                         { token (ITspec_inline_prag False) }
261   "{-#" $whitechar* (SOURCE|source) / { notFollowedByPragmaChar }
262                     { token ITsource_prag }
263   "{-#" $whitechar* (WARNING|warning) / { notFollowedByPragmaChar }
264                                         { token ITwarning_prag }
265   "{-#" $whitechar* (DEPRECATED|deprecated) / { notFollowedByPragmaChar }
266                                         { token ITdeprecated_prag }
267   "{-#" $whitechar* (SCC|scc)  / { notFollowedByPragmaChar }
268                     { token ITscc_prag }
269   "{-#" $whitechar* (GENERATED|generated) / { notFollowedByPragmaChar }
270                                         { token ITgenerated_prag }
271   "{-#" $whitechar* (CORE|core) / { notFollowedByPragmaChar }
272                     { token ITcore_prag }
273   "{-#" $whitechar* (UNPACK|unpack) / { notFollowedByPragmaChar }
274                     { token ITunpack_prag }
275   "{-#" $whitechar* (ANN|ann) / { notFollowedByPragmaChar }
276                     { token ITann_prag }
277
278   -- We ignore all these pragmas, but don't generate a warning for them
279   -- CFILES is a hugs-only thing.
280   "{-#" $whitechar* (OPTIONS_(HUGS|hugs|NHC98|nhc98|JHC|jhc|YHC|yhc|CATCH|catch|DERIVE|derive)|CFILES|cfiles|CONTRACT|contract) / { notFollowedByPragmaChar }
281                     { nested_comment lexToken }
282
283   -- ToDo: should only be valid inside a pragma:
284   "#-}"                                 { endPrag }
285 }
286
287 <option_prags> {
288   "{-#"  $whitechar* (OPTIONS|options) / { notFollowedByPragmaChar }
289                                         { lex_string_prag IToptions_prag }
290   "{-#"  $whitechar* (OPTIONS_GHC|options_ghc) / { notFollowedByPragmaChar }
291                                         { lex_string_prag IToptions_prag }
292   "{-#"  $whitechar* (OPTIONS_HADDOCK|options_haddock)
293                    / { notFollowedByPragmaChar }
294                                          { lex_string_prag ITdocOptions }
295   "-- #"                                 { multiline_doc_comment }
296   "{-#"  $whitechar* (LANGUAGE|language) / { notFollowedByPragmaChar }
297                                          { token ITlanguage_prag }
298   "{-#"  $whitechar* (INCLUDE|include) / { notFollowedByPragmaChar }
299                                          { lex_string_prag ITinclude_prag }
300 }
301
302 <0> {
303   -- In the "0" mode we ignore these pragmas
304   "{-#"  $whitechar* (OPTIONS|options|OPTIONS_GHC|options_ghc|OPTIONS_HADDOCK|options_haddock|LANGUAGE|language|INCLUDE|include) / { notFollowedByPragmaChar }
305                      { nested_comment lexToken }
306 }
307
308 <0> {
309   "-- #" .* { lineCommentToken }
310 }
311
312 <0,option_prags> {
313   "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
314                     (nested_comment lexToken) }
315 }
316
317 -- '0' state: ordinary lexemes
318
319 -- Haddock comments
320
321 <0> {
322   "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
323   "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
324 }
325
326 -- "special" symbols
327
328 <0> {
329   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
330   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
331 }
332   
333 <0> {
334   "[|"      / { ifExtension thEnabled } { token ITopenExpQuote }
335   "[e|"     / { ifExtension thEnabled } { token ITopenExpQuote }
336   "[p|"     / { ifExtension thEnabled } { token ITopenPatQuote }
337   "[d|"     / { ifExtension thEnabled } { layout_token ITopenDecQuote }
338   "[t|"     / { ifExtension thEnabled } { token ITopenTypQuote }
339   "|]"      / { ifExtension thEnabled } { token ITcloseQuote }
340   \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
341   "$("      / { ifExtension thEnabled } { token ITparenEscape }
342
343   "[$" @varid "|"  / { ifExtension qqEnabled }
344                      { lex_quasiquote_tok }
345 }
346
347 <0> {
348   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
349                                         { special IToparenbar }
350   "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
351 }
352
353 <0> {
354   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
355 }
356
357 <0> {
358   "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
359          { token IToubxparen }
360   "#)" / { ifExtension unboxedTuplesEnabled }
361          { token ITcubxparen }
362 }
363
364 <0> {
365   "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
366   "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
367 }
368
369 <0,option_prags> {
370   \(                                    { special IToparen }
371   \)                                    { special ITcparen }
372   \[                                    { special ITobrack }
373   \]                                    { special ITcbrack }
374   \,                                    { special ITcomma }
375   \;                                    { special ITsemi }
376   \`                                    { special ITbackquote }
377                                 
378   \{                                    { open_brace }
379   \}                                    { close_brace }
380 }
381
382 <0,option_prags> {
383   @qual @varid                  { idtoken qvarid }
384   @qual @conid                  { idtoken qconid }
385   @varid                        { varid }
386   @conid                        { idtoken conid }
387 }
388
389 <0> {
390   @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
391   @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
392   @varid "#"+       / { ifExtension magicHashEnabled } { varid }
393   @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
394 }
395
396 -- ToDo: - move `var` and (sym) into lexical syntax?
397 --       - remove backquote from $special?
398 <0> {
399   @qual @varsym       / { ifExtension oldQualOps } { idtoken qvarsym }
400   @qual @consym       / { ifExtension oldQualOps } { idtoken qconsym }
401   @qual \( @varsym \) / { ifExtension newQualOps } { idtoken prefixqvarsym }
402   @qual \( @consym \) / { ifExtension newQualOps } { idtoken prefixqconsym }
403   @varsym                                          { varsym }
404   @consym                                          { consym }
405 }
406
407 -- For the normal boxed literals we need to be careful
408 -- when trying to be close to Haskell98
409 <0> {
410   -- Normal integral literals (:: Num a => a, from Integer)
411   @decimal           { tok_num positive 0 0 decimal }
412   0[oO] @octal       { tok_num positive 2 2 octal }
413   0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
414
415   -- Normal rational literals (:: Fractional a => a, from Rational)
416   @floating_point    { strtoken tok_float }
417 }
418
419 <0> {
420   -- Unboxed ints (:: Int#) and words (:: Word#)
421   -- It's simpler (and faster?) to give separate cases to the negatives,
422   -- especially considering octal/hexadecimal prefixes.
423   @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
424   0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
425   0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
426   @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
427   @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
428   @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
429
430   @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
431   0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
432   0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
433
434   -- Unboxed floats and doubles (:: Float#, :: Double#)
435   -- prim_{float,double} work with signed literals
436   @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
437   @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
438 }
439
440 -- Strings and chars are lexed by hand-written code.  The reason is
441 -- that even if we recognise the string or char here in the regex
442 -- lexer, we would still have to parse the string afterward in order
443 -- to convert it to a String.
444 <0> {
445   \'                            { lex_char_tok }
446   \"                            { lex_string_tok }
447 }
448
449 {
450 -- -----------------------------------------------------------------------------
451 -- The token type
452
453 data Token
454   = ITas                        -- Haskell keywords
455   | ITcase
456   | ITclass
457   | ITdata
458   | ITdefault
459   | ITderiving
460   | ITdo
461   | ITelse
462   | IThiding
463   | ITif
464   | ITimport
465   | ITin
466   | ITinfix
467   | ITinfixl
468   | ITinfixr
469   | ITinstance
470   | ITlet
471   | ITmodule
472   | ITnewtype
473   | ITof
474   | ITqualified
475   | ITthen
476   | ITtype
477   | ITwhere
478   | ITscc                       -- ToDo: remove (we use {-# SCC "..." #-} now)
479
480   | ITforall                    -- GHC extension keywords
481   | ITforeign
482   | ITexport
483   | ITlabel
484   | ITdynamic
485   | ITsafe
486   | ITthreadsafe
487   | ITunsafe
488   | ITstdcallconv
489   | ITccallconv
490   | ITdotnet
491   | ITmdo
492   | ITfamily
493   | ITgroup
494   | ITby
495   | ITusing
496
497         -- Pragmas
498   | ITinline_prag Bool          -- True <=> INLINE, False <=> NOINLINE
499   | ITinline_conlike_prag Bool  -- same
500   | ITspec_prag                 -- SPECIALISE   
501   | ITspec_inline_prag Bool     -- SPECIALISE INLINE (or NOINLINE)
502   | ITsource_prag
503   | ITrules_prag
504   | ITwarning_prag
505   | ITdeprecated_prag
506   | ITline_prag
507   | ITscc_prag
508   | ITgenerated_prag
509   | ITcore_prag                 -- hdaume: core annotations
510   | ITunpack_prag
511   | ITann_prag
512   | ITclose_prag
513   | IToptions_prag String
514   | ITinclude_prag String
515   | ITlanguage_prag
516
517   | ITdotdot                    -- reserved symbols
518   | ITcolon
519   | ITdcolon
520   | ITequal
521   | ITlam
522   | ITvbar
523   | ITlarrow
524   | ITrarrow
525   | ITat
526   | ITtilde
527   | ITdarrow
528   | ITminus
529   | ITbang
530   | ITstar
531   | ITdot
532
533   | ITbiglam                    -- GHC-extension symbols
534
535   | ITocurly                    -- special symbols
536   | ITccurly
537   | ITocurlybar                 -- {|, for type applications
538   | ITccurlybar                 -- |}, for type applications
539   | ITvocurly
540   | ITvccurly
541   | ITobrack
542   | ITopabrack                  -- [:, for parallel arrays with -XParr
543   | ITcpabrack                  -- :], for parallel arrays with -XParr
544   | ITcbrack
545   | IToparen
546   | ITcparen
547   | IToubxparen
548   | ITcubxparen
549   | ITsemi
550   | ITcomma
551   | ITunderscore
552   | ITbackquote
553
554   | ITvarid   FastString        -- identifiers
555   | ITconid   FastString
556   | ITvarsym  FastString
557   | ITconsym  FastString
558   | ITqvarid  (FastString,FastString)
559   | ITqconid  (FastString,FastString)
560   | ITqvarsym (FastString,FastString)
561   | ITqconsym (FastString,FastString)
562   | ITprefixqvarsym (FastString,FastString)
563   | ITprefixqconsym (FastString,FastString)
564
565   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
566
567   | ITpragma StringBuffer
568
569   | ITchar       Char
570   | ITstring     FastString
571   | ITinteger    Integer
572   | ITrational   Rational
573
574   | ITprimchar   Char
575   | ITprimstring FastString
576   | ITprimint    Integer
577   | ITprimword   Integer
578   | ITprimfloat  Rational
579   | ITprimdouble Rational
580
581   -- MetaHaskell extension tokens
582   | ITopenExpQuote              --  [| or [e|
583   | ITopenPatQuote              --  [p|
584   | ITopenDecQuote              --  [d|
585   | ITopenTypQuote              --  [t|         
586   | ITcloseQuote                --  |]
587   | ITidEscape   FastString     --  $x
588   | ITparenEscape               --  $( 
589   | ITvarQuote                  --  '
590   | ITtyQuote                   --  ''
591   | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
592
593   -- Arrow notation extension
594   | ITproc
595   | ITrec
596   | IToparenbar                 --  (|
597   | ITcparenbar                 --  |)
598   | ITlarrowtail                --  -<
599   | ITrarrowtail                --  >-
600   | ITLarrowtail                --  -<<
601   | ITRarrowtail                --  >>-
602
603   | ITunknown String            -- Used when the lexer can't make sense of it
604   | ITeof                       -- end of file token
605
606   -- Documentation annotations
607   | ITdocCommentNext  String     -- something beginning '-- |'
608   | ITdocCommentPrev  String     -- something beginning '-- ^'
609   | ITdocCommentNamed String     -- something beginning '-- $'
610   | ITdocSection      Int String -- a section heading
611   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
612   | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
613   | ITlineComment     String     -- comment starting by "--"
614   | ITblockComment    String     -- comment in {- -}
615
616 #ifdef DEBUG
617   deriving Show -- debugging
618 #endif
619
620 {-
621 isSpecial :: Token -> Bool
622 -- If we see M.x, where x is a keyword, but
623 -- is special, we treat is as just plain M.x, 
624 -- not as a keyword.
625 isSpecial ITas          = True
626 isSpecial IThiding      = True
627 isSpecial ITqualified   = True
628 isSpecial ITforall      = True
629 isSpecial ITexport      = True
630 isSpecial ITlabel       = True
631 isSpecial ITdynamic     = True
632 isSpecial ITsafe        = True
633 isSpecial ITthreadsafe  = True
634 isSpecial ITunsafe      = True
635 isSpecial ITccallconv   = True
636 isSpecial ITstdcallconv = True
637 isSpecial ITmdo         = True
638 isSpecial ITfamily      = True
639 isSpecial ITgroup   = True
640 isSpecial ITby      = True
641 isSpecial ITusing   = True
642 isSpecial _             = False
643 -}
644
645 -- the bitmap provided as the third component indicates whether the
646 -- corresponding extension keyword is valid under the extension options
647 -- provided to the compiler; if the extension corresponding to *any* of the
648 -- bits set in the bitmap is enabled, the keyword is valid (this setup
649 -- facilitates using a keyword in two different extensions that can be
650 -- activated independently)
651 --
652 reservedWordsFM = listToUFM $
653         map (\(x, y, z) -> (mkFastString x, (y, z)))
654        [( "_",          ITunderscore,   0 ),
655         ( "as",         ITas,           0 ),
656         ( "case",       ITcase,         0 ),     
657         ( "class",      ITclass,        0 ),    
658         ( "data",       ITdata,         0 ),     
659         ( "default",    ITdefault,      0 ),  
660         ( "deriving",   ITderiving,     0 ), 
661         ( "do",         ITdo,           0 ),       
662         ( "else",       ITelse,         0 ),     
663         ( "hiding",     IThiding,       0 ),
664         ( "if",         ITif,           0 ),       
665         ( "import",     ITimport,       0 ),   
666         ( "in",         ITin,           0 ),       
667         ( "infix",      ITinfix,        0 ),    
668         ( "infixl",     ITinfixl,       0 ),   
669         ( "infixr",     ITinfixr,       0 ),   
670         ( "instance",   ITinstance,     0 ), 
671         ( "let",        ITlet,          0 ),      
672         ( "module",     ITmodule,       0 ),   
673         ( "newtype",    ITnewtype,      0 ),  
674         ( "of",         ITof,           0 ),       
675         ( "qualified",  ITqualified,    0 ),
676         ( "then",       ITthen,         0 ),     
677         ( "type",       ITtype,         0 ),     
678         ( "where",      ITwhere,        0 ),
679         ( "_scc_",      ITscc,          0 ),            -- ToDo: remove
680
681     ( "forall", ITforall,        bit explicitForallBit .|. bit inRulePragBit),
682         ( "mdo",        ITmdo,           bit recursiveDoBit),
683         ( "family",     ITfamily,        bit tyFamBit),
684     ( "group",  ITgroup,     bit transformComprehensionsBit),
685     ( "by",     ITby,        bit transformComprehensionsBit),
686     ( "using",  ITusing,     bit transformComprehensionsBit),
687
688         ( "foreign",    ITforeign,       bit ffiBit),
689         ( "export",     ITexport,        bit ffiBit),
690         ( "label",      ITlabel,         bit ffiBit),
691         ( "dynamic",    ITdynamic,       bit ffiBit),
692         ( "safe",       ITsafe,          bit ffiBit),
693         ( "threadsafe", ITthreadsafe,    bit ffiBit),
694         ( "unsafe",     ITunsafe,        bit ffiBit),
695         ( "stdcall",    ITstdcallconv,   bit ffiBit),
696         ( "ccall",      ITccallconv,     bit ffiBit),
697         ( "dotnet",     ITdotnet,        bit ffiBit),
698
699         ( "rec",        ITrec,           bit arrowsBit),
700         ( "proc",       ITproc,          bit arrowsBit)
701      ]
702
703 reservedSymsFM :: UniqFM (Token, Int -> Bool)
704 reservedSymsFM = listToUFM $
705     map (\ (x,y,z) -> (mkFastString x,(y,z)))
706       [ ("..",  ITdotdot,   always)
707         -- (:) is a reserved op, meaning only list cons
708        ,(":",   ITcolon,    always)
709        ,("::",  ITdcolon,   always)
710        ,("=",   ITequal,    always)
711        ,("\\",  ITlam,      always)
712        ,("|",   ITvbar,     always)
713        ,("<-",  ITlarrow,   always)
714        ,("->",  ITrarrow,   always)
715        ,("@",   ITat,       always)
716        ,("~",   ITtilde,    always)
717        ,("=>",  ITdarrow,   always)
718        ,("-",   ITminus,    always)
719        ,("!",   ITbang,     always)
720
721         -- For data T (a::*) = MkT
722        ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i)
723         -- For 'forall a . t'
724        ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
725
726        ,("-<",  ITlarrowtail, arrowsEnabled)
727        ,(">-",  ITrarrowtail, arrowsEnabled)
728        ,("-<<", ITLarrowtail, arrowsEnabled)
729        ,(">>-", ITRarrowtail, arrowsEnabled)
730
731        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
732        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
733        ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i &&
734                                 explicitForallEnabled i)
735        ,("→",   ITrarrow, unicodeSyntaxEnabled)
736        ,("←",   ITlarrow, unicodeSyntaxEnabled)
737        ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
738         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
739         -- form part of a large operator.  This would let us have a better
740         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
741        ]
742
743 -- -----------------------------------------------------------------------------
744 -- Lexer actions
745
746 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
747
748 special :: Token -> Action
749 special tok span _buf _len = return (L span tok)
750
751 token, layout_token :: Token -> Action
752 token t span _buf _len = return (L span t)
753 layout_token t span _buf _len = pushLexState layout >> return (L span t)
754
755 idtoken :: (StringBuffer -> Int -> Token) -> Action
756 idtoken f span buf len = return (L span $! (f buf len))
757
758 skip_one_varid :: (FastString -> Token) -> Action
759 skip_one_varid f span buf len 
760   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
761
762 strtoken :: (String -> Token) -> Action
763 strtoken f span buf len = 
764   return (L span $! (f $! lexemeToString buf len))
765
766 init_strtoken :: Int -> (String -> Token) -> Action
767 -- like strtoken, but drops the last N character(s)
768 init_strtoken drop f span buf len = 
769   return (L span $! (f $! lexemeToString buf (len-drop)))
770
771 begin :: Int -> Action
772 begin code _span _str _len = do pushLexState code; lexToken
773
774 pop :: Action
775 pop _span _buf _len = do popLexState; lexToken
776
777 pop_and :: Action -> Action
778 pop_and act span buf len = do popLexState; act span buf len
779
780 {-# INLINE nextCharIs #-}
781 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
782
783 notFollowedBy char _ _ _ (AI _ _ buf) 
784   = nextCharIs buf (/=char)
785
786 notFollowedBySymbol _ _ _ (AI _ _ buf)
787   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
788
789 notFollowedByPragmaChar _ _ _ (AI _ _ buf)
790   = nextCharIs buf (\c -> not (isAlphaNum c || c == '_'))
791
792 -- We must reject doc comments as being ordinary comments everywhere.
793 -- In some cases the doc comment will be selected as the lexeme due to
794 -- maximal munch, but not always, because the nested comment rule is
795 -- valid in all states, but the doc-comment rules are only valid in
796 -- the non-layout states.
797 isNormalComment bits _ _ (AI _ _ buf)
798   | haddockEnabled bits = notFollowedByDocOrPragma
799   | otherwise           = nextCharIs buf (/='#')
800   where
801     notFollowedByDocOrPragma
802        = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
803
804 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
805
806 {-
807 haddockDisabledAnd p bits _ _ (AI _ _ buf)
808   = if haddockEnabled bits then False else (p buf)
809 -}
810
811 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
812
813 ifExtension pred bits _ _ _ = pred bits
814
815 multiline_doc_comment :: Action
816 multiline_doc_comment span buf _len = withLexedDocType (worker "")
817   where
818     worker commentAcc input docType oneLine = case alexGetChar input of
819       Just ('\n', input') 
820         | oneLine -> docCommentEnd input commentAcc docType buf span
821         | otherwise -> case checkIfCommentLine input' of
822           Just input -> worker ('\n':commentAcc) input docType False
823           Nothing -> docCommentEnd input commentAcc docType buf span
824       Just (c, input) -> worker (c:commentAcc) input docType oneLine
825       Nothing -> docCommentEnd input commentAcc docType buf span
826       
827     checkIfCommentLine input = check (dropNonNewlineSpace input)
828       where
829         check input = case alexGetChar input of
830           Just ('-', input) -> case alexGetChar input of
831             Just ('-', input) -> case alexGetChar input of
832               Just (c, _) | c /= '-' -> Just input
833               _ -> Nothing
834             _ -> Nothing
835           _ -> Nothing
836
837         dropNonNewlineSpace input = case alexGetChar input of
838           Just (c, input') 
839             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
840             | otherwise -> input
841           Nothing -> input
842
843 lineCommentToken :: Action
844 lineCommentToken span buf len = do
845   b <- extension rawTokenStreamEnabled
846   if b then strtoken ITlineComment span buf len else lexToken
847
848 {-
849   nested comments require traversing by hand, they can't be parsed
850   using regular expressions.
851 -}
852 nested_comment :: P (Located Token) -> Action
853 nested_comment cont span _str _len = do
854   input <- getInput
855   go "" (1::Int) input
856   where
857     go commentAcc 0 input = do setInput input
858                                b <- extension rawTokenStreamEnabled
859                                if b
860                                  then docCommentEnd input commentAcc ITblockComment _str span
861                                  else cont
862     go commentAcc n input = case alexGetChar input of
863       Nothing -> errBrace input span
864       Just ('-',input) -> case alexGetChar input of
865         Nothing  -> errBrace input span
866         Just ('\125',input) -> go commentAcc (n-1) input
867         Just (_,_)          -> go ('-':commentAcc) n input
868       Just ('\123',input) -> case alexGetChar input of
869         Nothing  -> errBrace input span
870         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
871         Just (_,_)       -> go ('\123':commentAcc) n input
872       Just (c,input) -> go (c:commentAcc) n input
873
874 nested_doc_comment :: Action
875 nested_doc_comment span buf _len = withLexedDocType (go "")
876   where
877     go commentAcc input docType _ = case alexGetChar input of
878       Nothing -> errBrace input span
879       Just ('-',input) -> case alexGetChar input of
880         Nothing -> errBrace input span
881         Just ('\125',input) ->
882           docCommentEnd input commentAcc docType buf span
883         Just (_,_) -> go ('-':commentAcc) input docType False
884       Just ('\123', input) -> case alexGetChar input of
885         Nothing  -> errBrace input span
886         Just ('-',input) -> do
887           setInput input
888           let cont = do input <- getInput; go commentAcc input docType False
889           nested_comment cont span buf _len
890         Just (_,_) -> go ('\123':commentAcc) input docType False
891       Just (c,input) -> go (c:commentAcc) input docType False
892
893 withLexedDocType lexDocComment = do
894   input@(AI _ _ buf) <- getInput
895   case prevChar buf ' ' of
896     '|' -> lexDocComment input ITdocCommentNext False
897     '^' -> lexDocComment input ITdocCommentPrev False
898     '$' -> lexDocComment input ITdocCommentNamed False
899     '*' -> lexDocSection 1 input
900     '#' -> lexDocComment input ITdocOptionsOld False
901  where 
902     lexDocSection n input = case alexGetChar input of 
903       Just ('*', input) -> lexDocSection (n+1) input
904       Just (_,   _)     -> lexDocComment input (ITdocSection n) True
905       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
906
907 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
908 -- off again at the end of the pragma.
909 rulePrag :: Action
910 rulePrag span buf len = do
911   setExts (.|. bit inRulePragBit)
912   return (L span ITrules_prag)
913
914 endPrag :: Action
915 endPrag span buf len = do
916   setExts (.&. complement (bit inRulePragBit))
917   return (L span ITclose_prag)
918
919 -- docCommentEnd
920 -------------------------------------------------------------------------------
921 -- This function is quite tricky. We can't just return a new token, we also
922 -- need to update the state of the parser. Why? Because the token is longer
923 -- than what was lexed by Alex, and the lexToken function doesn't know this, so 
924 -- it writes the wrong token length to the parser state. This function is
925 -- called afterwards, so it can just update the state. 
926
927 -- This is complicated by the fact that Haddock tokens can span multiple lines, 
928 -- which is something that the original lexer didn't account for. 
929 -- I have added last_line_len in the parser state which represents the length 
930 -- of the part of the token that is on the last line. It is now used for layout 
931 -- calculation in pushCurrentContext instead of last_len. last_len is, like it 
932 -- was before, the full length of the token, and it is now only used for error
933 -- messages. /Waern 
934
935 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
936                  SrcSpan -> P (Located Token) 
937 docCommentEnd input commentAcc docType buf span = do
938   setInput input
939   let (AI loc last_offs nextBuf) = input
940       comment = reverse commentAcc
941       span' = mkSrcSpan (srcSpanStart span) loc
942       last_len = byteDiff buf nextBuf
943       
944       last_line_len = if (last_offs - last_len < 0) 
945         then last_offs
946         else last_len  
947   
948   span `seq` setLastToken span' last_len last_line_len
949   return (L span' (docType comment))
950  
951 errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
952  
953 open_brace, close_brace :: Action
954 open_brace span _str _len = do 
955   ctx <- getContext
956   setContext (NoLayout:ctx)
957   return (L span ITocurly)
958 close_brace span _str _len = do 
959   popContext
960   return (L span ITccurly)
961
962 qvarid buf len = ITqvarid $! splitQualName buf len False
963 qconid buf len = ITqconid $! splitQualName buf len False
964
965 splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)
966 -- takes a StringBuffer and a length, and returns the module name
967 -- and identifier parts of a qualified name.  Splits at the *last* dot,
968 -- because of hierarchical module names.
969 splitQualName orig_buf len parens = split orig_buf orig_buf
970   where
971     split buf dot_buf
972         | orig_buf `byteDiff` buf >= len  = done dot_buf
973         | c == '.'                        = found_dot buf'
974         | otherwise                       = split buf' dot_buf
975       where
976        (c,buf') = nextChar buf
977   
978     -- careful, we might get names like M....
979     -- so, if the character after the dot is not upper-case, this is
980     -- the end of the qualifier part.
981     found_dot buf -- buf points after the '.'
982         | isUpper c    = split buf' buf
983         | otherwise    = done buf
984       where
985        (c,buf') = nextChar buf
986
987     done dot_buf =
988         (lexemeToFastString orig_buf (qual_size - 1),
989          if parens -- Prelude.(+)
990             then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)
991             else lexemeToFastString dot_buf (len - qual_size))
992       where
993         qual_size = orig_buf `byteDiff` dot_buf
994
995 varid span buf len = 
996   fs `seq`
997   case lookupUFM reservedWordsFM fs of
998         Just (keyword,0)    -> do
999                 maybe_layout keyword
1000                 return (L span keyword)
1001         Just (keyword,exts) -> do
1002                 b <- extension (\i -> exts .&. i /= 0)
1003                 if b then do maybe_layout keyword
1004                              return (L span keyword)
1005                      else return (L span (ITvarid fs))
1006         _other -> return (L span (ITvarid fs))
1007   where
1008         fs = lexemeToFastString buf len
1009
1010 conid buf len = ITconid fs
1011   where fs = lexemeToFastString buf len
1012
1013 qvarsym buf len = ITqvarsym $! splitQualName buf len False
1014 qconsym buf len = ITqconsym $! splitQualName buf len False
1015 prefixqvarsym buf len = ITprefixqvarsym $! splitQualName buf len True
1016 prefixqconsym buf len = ITprefixqconsym $! splitQualName buf len True
1017
1018 varsym = sym ITvarsym
1019 consym = sym ITconsym
1020
1021 sym con span buf len = 
1022   case lookupUFM reservedSymsFM fs of
1023         Just (keyword,exts) -> do
1024                 b <- extension exts
1025                 if b then return (L span keyword)
1026                      else return (L span $! con fs)
1027         _other -> return (L span $! con fs)
1028   where
1029         fs = lexemeToFastString buf len
1030
1031 -- Variations on the integral numeric literal.
1032 tok_integral :: (Integer -> Token)
1033      -> (Integer -> Integer)
1034  --    -> (StringBuffer -> StringBuffer) -> (Int -> Int)
1035      -> Int -> Int
1036      -> (Integer, (Char->Int)) -> Action
1037 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
1038   return $ L span $ itint $! transint $ parseUnsignedInteger
1039      (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
1040
1041 -- some conveniences for use with tok_integral
1042 tok_num = tok_integral ITinteger
1043 tok_primint = tok_integral ITprimint
1044 tok_primword = tok_integral ITprimword positive
1045 positive = id
1046 negative = negate
1047 decimal = (10,octDecDigit)
1048 octal = (8,octDecDigit)
1049 hexadecimal = (16,hexDigit)
1050
1051 -- readRational can understand negative rationals, exponents, everything.
1052 tok_float        str = ITrational   $! readRational str
1053 tok_primfloat    str = ITprimfloat  $! readRational str
1054 tok_primdouble   str = ITprimdouble $! readRational str
1055
1056 -- -----------------------------------------------------------------------------
1057 -- Layout processing
1058
1059 -- we're at the first token on a line, insert layout tokens if necessary
1060 do_bol :: Action
1061 do_bol span _str _len = do
1062         pos <- getOffside
1063         case pos of
1064             LT -> do
1065                 --trace "layout: inserting '}'" $ do
1066                 popContext
1067                 -- do NOT pop the lex state, we might have a ';' to insert
1068                 return (L span ITvccurly)
1069             EQ -> do
1070                 --trace "layout: inserting ';'" $ do
1071                 popLexState
1072                 return (L span ITsemi)
1073             GT -> do
1074                 popLexState
1075                 lexToken
1076
1077 -- certain keywords put us in the "layout" state, where we might
1078 -- add an opening curly brace.
1079 maybe_layout ITdo       = pushLexState layout_do
1080 maybe_layout ITmdo      = pushLexState layout_do
1081 maybe_layout ITof       = pushLexState layout
1082 maybe_layout ITlet      = pushLexState layout
1083 maybe_layout ITwhere    = pushLexState layout
1084 maybe_layout ITrec      = pushLexState layout
1085 maybe_layout _          = return ()
1086
1087 -- Pushing a new implicit layout context.  If the indentation of the
1088 -- next token is not greater than the previous layout context, then
1089 -- Haskell 98 says that the new layout context should be empty; that is
1090 -- the lexer must generate {}.
1091 --
1092 -- We are slightly more lenient than this: when the new context is started
1093 -- by a 'do', then we allow the new context to be at the same indentation as
1094 -- the previous context.  This is what the 'strict' argument is for.
1095 --
1096 new_layout_context strict span _buf _len = do
1097     popLexState
1098     (AI _ offset _) <- getInput
1099     ctx <- getContext
1100     case ctx of
1101         Layout prev_off : _  | 
1102            (strict     && prev_off >= offset  ||
1103             not strict && prev_off > offset) -> do
1104                 -- token is indented to the left of the previous context.
1105                 -- we must generate a {} sequence now.
1106                 pushLexState layout_left
1107                 return (L span ITvocurly)
1108         _ -> do
1109                 setContext (Layout offset : ctx)
1110                 return (L span ITvocurly)
1111
1112 do_layout_left span _buf _len = do
1113     popLexState
1114     pushLexState bol  -- we must be at the start of a line
1115     return (L span ITvccurly)
1116
1117 -- -----------------------------------------------------------------------------
1118 -- LINE pragmas
1119
1120 setLine :: Int -> Action
1121 setLine code span buf len = do
1122   let line = parseUnsignedInteger buf len 10 octDecDigit
1123   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
1124         -- subtract one: the line number refers to the *following* line
1125   popLexState
1126   pushLexState code
1127   lexToken
1128
1129 setFile :: Int -> Action
1130 setFile code span buf len = do
1131   let file = lexemeToFastString (stepOn buf) (len-2)
1132   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1133   popLexState
1134   pushLexState code
1135   lexToken
1136
1137
1138 -- -----------------------------------------------------------------------------
1139 -- Options, includes and language pragmas.
1140
1141 lex_string_prag :: (String -> Token) -> Action
1142 lex_string_prag mkTok span _buf _len
1143     = do input <- getInput
1144          start <- getSrcLoc
1145          tok <- go [] input
1146          end <- getSrcLoc
1147          return (L (mkSrcSpan start end) tok)
1148     where go acc input
1149               = if isString input "#-}"
1150                    then do setInput input
1151                            return (mkTok (reverse acc))
1152                    else case alexGetChar input of
1153                           Just (c,i) -> go (c:acc) i
1154                           Nothing -> err input
1155           isString _ [] = True
1156           isString i (x:xs)
1157               = case alexGetChar i of
1158                   Just (c,i') | c == x    -> isString i' xs
1159                   _other -> False
1160           err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1161
1162
1163 -- -----------------------------------------------------------------------------
1164 -- Strings & Chars
1165
1166 -- This stuff is horrible.  I hates it.
1167
1168 lex_string_tok :: Action
1169 lex_string_tok span _buf _len = do
1170   tok <- lex_string ""
1171   end <- getSrcLoc 
1172   return (L (mkSrcSpan (srcSpanStart span) end) tok)
1173
1174 lex_string :: String -> P Token
1175 lex_string s = do
1176   i <- getInput
1177   case alexGetChar' i of
1178     Nothing -> lit_error
1179
1180     Just ('"',i)  -> do
1181         setInput i
1182         magicHash <- extension magicHashEnabled
1183         if magicHash
1184           then do
1185             i <- getInput
1186             case alexGetChar' i of
1187               Just ('#',i) -> do
1188                    setInput i
1189                    if any (> '\xFF') s
1190                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1191                     else let s' = mkZFastString (reverse s) in
1192                          return (ITprimstring s')
1193                         -- mkZFastString is a hack to avoid encoding the
1194                         -- string in UTF-8.  We just want the exact bytes.
1195               _other ->
1196                 return (ITstring (mkFastString (reverse s)))
1197           else
1198                 return (ITstring (mkFastString (reverse s)))
1199
1200     Just ('\\',i)
1201         | Just ('&',i) <- next -> do 
1202                 setInput i; lex_string s
1203         | Just (c,i) <- next, is_space c -> do 
1204                 setInput i; lex_stringgap s
1205         where next = alexGetChar' i
1206
1207     Just (c, i) -> do
1208         c' <- lex_char c i
1209         lex_string (c':s)
1210
1211 lex_stringgap s = do
1212   c <- getCharOrFail
1213   case c of
1214     '\\' -> lex_string s
1215     c | is_space c -> lex_stringgap s
1216     _other -> lit_error
1217
1218
1219 lex_char_tok :: Action
1220 -- Here we are basically parsing character literals, such as 'x' or '\n'
1221 -- but, when Template Haskell is on, we additionally spot
1222 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, 
1223 -- but WIHTOUT CONSUMING the x or T part  (the parser does that).
1224 -- So we have to do two characters of lookahead: when we see 'x we need to
1225 -- see if there's a trailing quote
1226 lex_char_tok span _buf _len = do        -- We've seen '
1227    i1 <- getInput       -- Look ahead to first character
1228    let loc = srcSpanStart span
1229    case alexGetChar' i1 of
1230         Nothing -> lit_error 
1231
1232         Just ('\'', i2@(AI end2 _ _)) -> do     -- We've seen ''
1233                   th_exts <- extension thEnabled
1234                   if th_exts then do
1235                         setInput i2
1236                         return (L (mkSrcSpan loc end2)  ITtyQuote)
1237                    else lit_error
1238
1239         Just ('\\', i2@(AI _end2 _ _)) -> do    -- We've seen 'backslash
1240                   setInput i2
1241                   lit_ch <- lex_escape
1242                   mc <- getCharOrFail   -- Trailing quote
1243                   if mc == '\'' then finish_char_tok loc lit_ch
1244                                 else do setInput i2; lit_error 
1245
1246         Just (c, i2@(AI _end2 _ _))
1247                 | not (isAny c) -> lit_error
1248                 | otherwise ->
1249
1250                 -- We've seen 'x, where x is a valid character
1251                 --  (i.e. not newline etc) but not a quote or backslash
1252            case alexGetChar' i2 of      -- Look ahead one more character
1253                 Just ('\'', i3) -> do   -- We've seen 'x'
1254                         setInput i3 
1255                         finish_char_tok loc c
1256                 _other -> do            -- We've seen 'x not followed by quote
1257                                         -- (including the possibility of EOF)
1258                                         -- If TH is on, just parse the quote only
1259                         th_exts <- extension thEnabled  
1260                         let (AI end _ _) = i1
1261                         if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1262                                    else do setInput i2; lit_error
1263
1264 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1265 finish_char_tok loc ch  -- We've already seen the closing quote
1266                         -- Just need to check for trailing #
1267   = do  magicHash <- extension magicHashEnabled
1268         i@(AI end _ _) <- getInput
1269         if magicHash then do
1270                 case alexGetChar' i of
1271                         Just ('#',i@(AI end _ _)) -> do
1272                                 setInput i
1273                                 return (L (mkSrcSpan loc end) (ITprimchar ch))
1274                         _other ->
1275                                 return (L (mkSrcSpan loc end) (ITchar ch))
1276                 else do
1277                    return (L (mkSrcSpan loc end) (ITchar ch))
1278
1279 lex_char :: Char -> AlexInput -> P Char
1280 lex_char c inp = do
1281   case c of
1282       '\\' -> do setInput inp; lex_escape
1283       c | isAny c -> do setInput inp; return c
1284       _other -> lit_error
1285
1286 isAny c | c > '\x7f' = isPrint c
1287         | otherwise  = is_any c
1288
1289 lex_escape :: P Char
1290 lex_escape = do
1291   c <- getCharOrFail
1292   case c of
1293         'a'   -> return '\a'
1294         'b'   -> return '\b'
1295         'f'   -> return '\f'
1296         'n'   -> return '\n'
1297         'r'   -> return '\r'
1298         't'   -> return '\t'
1299         'v'   -> return '\v'
1300         '\\'  -> return '\\'
1301         '"'   -> return '\"'
1302         '\''  -> return '\''
1303         '^'   -> do c <- getCharOrFail
1304                     if c >= '@' && c <= '_'
1305                         then return (chr (ord c - ord '@'))
1306                         else lit_error
1307
1308         'x'   -> readNum is_hexdigit 16 hexDigit
1309         'o'   -> readNum is_octdigit  8 octDecDigit
1310         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1311
1312         c1 ->  do
1313            i <- getInput
1314            case alexGetChar' i of
1315             Nothing -> lit_error
1316             Just (c2,i2) -> 
1317               case alexGetChar' i2 of
1318                 Nothing -> do setInput i2; lit_error
1319                 Just (c3,i3) -> 
1320                    let str = [c1,c2,c3] in
1321                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1322                                      Just rest <- [maybePrefixMatch p str] ] of
1323                           (escape_char,[]):_ -> do
1324                                 setInput i3
1325                                 return escape_char
1326                           (escape_char,_:_):_ -> do
1327                                 setInput i2
1328                                 return escape_char
1329                           [] -> lit_error
1330
1331 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1332 readNum is_digit base conv = do
1333   i <- getInput
1334   c <- getCharOrFail
1335   if is_digit c 
1336         then readNum2 is_digit base conv (conv c)
1337         else do setInput i; lit_error
1338
1339 readNum2 is_digit base conv i = do
1340   input <- getInput
1341   read i input
1342   where read i input = do
1343           case alexGetChar' input of
1344             Just (c,input') | is_digit c -> do
1345                 read (i*base + conv c) input'
1346             _other -> do
1347                 if i >= 0 && i <= 0x10FFFF
1348                    then do setInput input; return (chr i)
1349                    else lit_error
1350
1351 silly_escape_chars = [
1352         ("NUL", '\NUL'),
1353         ("SOH", '\SOH'),
1354         ("STX", '\STX'),
1355         ("ETX", '\ETX'),
1356         ("EOT", '\EOT'),
1357         ("ENQ", '\ENQ'),
1358         ("ACK", '\ACK'),
1359         ("BEL", '\BEL'),
1360         ("BS", '\BS'),
1361         ("HT", '\HT'),
1362         ("LF", '\LF'),
1363         ("VT", '\VT'),
1364         ("FF", '\FF'),
1365         ("CR", '\CR'),
1366         ("SO", '\SO'),
1367         ("SI", '\SI'),
1368         ("DLE", '\DLE'),
1369         ("DC1", '\DC1'),
1370         ("DC2", '\DC2'),
1371         ("DC3", '\DC3'),
1372         ("DC4", '\DC4'),
1373         ("NAK", '\NAK'),
1374         ("SYN", '\SYN'),
1375         ("ETB", '\ETB'),
1376         ("CAN", '\CAN'),
1377         ("EM", '\EM'),
1378         ("SUB", '\SUB'),
1379         ("ESC", '\ESC'),
1380         ("FS", '\FS'),
1381         ("GS", '\GS'),
1382         ("RS", '\RS'),
1383         ("US", '\US'),
1384         ("SP", '\SP'),
1385         ("DEL", '\DEL')
1386         ]
1387
1388 -- before calling lit_error, ensure that the current input is pointing to
1389 -- the position of the error in the buffer.  This is so that we can report
1390 -- a correct location to the user, but also so we can detect UTF-8 decoding
1391 -- errors if they occur.
1392 lit_error = lexError "lexical error in string/character literal"
1393
1394 getCharOrFail :: P Char
1395 getCharOrFail =  do
1396   i <- getInput
1397   case alexGetChar' i of
1398         Nothing -> lexError "unexpected end-of-file in string/character literal"
1399         Just (c,i)  -> do setInput i; return c
1400
1401 -- -----------------------------------------------------------------------------
1402 -- QuasiQuote
1403
1404 lex_quasiquote_tok :: Action
1405 lex_quasiquote_tok span buf len = do
1406   let quoter = reverse $ takeWhile (/= '$')
1407                $ reverse $ lexemeToString buf (len - 1)
1408   quoteStart <- getSrcLoc              
1409   quote <- lex_quasiquote ""
1410   end <- getSrcLoc 
1411   return (L (mkSrcSpan (srcSpanStart span) end)
1412            (ITquasiQuote (mkFastString quoter,
1413                           mkFastString (reverse quote),
1414                           mkSrcSpan quoteStart end)))
1415
1416 lex_quasiquote :: String -> P String
1417 lex_quasiquote s = do
1418   i <- getInput
1419   case alexGetChar' i of
1420     Nothing -> lit_error
1421
1422     Just ('\\',i)
1423         | Just ('|',i) <- next -> do 
1424                 setInput i; lex_quasiquote ('|' : s)
1425         | Just (']',i) <- next -> do 
1426                 setInput i; lex_quasiquote (']' : s)
1427         where next = alexGetChar' i
1428
1429     Just ('|',i)
1430         | Just (']',i) <- next -> do 
1431                 setInput i; return s
1432         where next = alexGetChar' i
1433
1434     Just (c, i) -> do
1435          setInput i; lex_quasiquote (c : s)
1436
1437 -- -----------------------------------------------------------------------------
1438 -- Warnings
1439
1440 warn :: DynFlag -> SDoc -> Action
1441 warn option warning srcspan _buf _len = do
1442     addWarning option srcspan warning
1443     lexToken
1444
1445 warnThen :: DynFlag -> SDoc -> Action -> Action
1446 warnThen option warning action srcspan buf len = do
1447     addWarning option srcspan warning
1448     action srcspan buf len
1449
1450 -- -----------------------------------------------------------------------------
1451 -- The Parse Monad
1452
1453 data LayoutContext
1454   = NoLayout
1455   | Layout !Int
1456   deriving Show
1457
1458 data ParseResult a
1459   = POk PState a
1460   | PFailed 
1461         SrcSpan         -- The start and end of the text span related to
1462                         -- the error.  Might be used in environments which can 
1463                         -- show this span, e.g. by highlighting it.
1464         Message         -- The error message
1465
1466 data PState = PState { 
1467         buffer     :: StringBuffer,
1468     dflags     :: DynFlags,
1469     messages   :: Messages,
1470         last_loc   :: SrcSpan,  -- pos of previous token
1471         last_offs  :: !Int,     -- offset of the previous token from the
1472                                 -- beginning of  the current line.
1473                                 -- \t is equal to 8 spaces.
1474         last_len   :: !Int,     -- len of previous token
1475   last_line_len :: !Int,
1476         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
1477         extsBitmap :: !Int,     -- bitmap that determines permitted extensions
1478         context    :: [LayoutContext],
1479         lex_state  :: [Int]
1480      }
1481         -- last_loc and last_len are used when generating error messages,
1482         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1483         -- current token to happyError, we could at least get rid of last_len.
1484         -- Getting rid of last_loc would require finding another way to 
1485         -- implement pushCurrentContext (which is only called from one place).
1486
1487 newtype P a = P { unP :: PState -> ParseResult a }
1488
1489 instance Monad P where
1490   return = returnP
1491   (>>=) = thenP
1492   fail = failP
1493
1494 returnP :: a -> P a
1495 returnP a = a `seq` (P $ \s -> POk s a)
1496
1497 thenP :: P a -> (a -> P b) -> P b
1498 (P m) `thenP` k = P $ \ s ->
1499         case m s of
1500                 POk s1 a         -> (unP (k a)) s1
1501                 PFailed span err -> PFailed span err
1502
1503 failP :: String -> P a
1504 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1505
1506 failMsgP :: String -> P a
1507 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1508
1509 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1510 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
1511
1512 failSpanMsgP :: SrcSpan -> SDoc -> P a
1513 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1514
1515 extension :: (Int -> Bool) -> P Bool
1516 extension p = P $ \s -> POk s (p $! extsBitmap s)
1517
1518 getExts :: P Int
1519 getExts = P $ \s -> POk s (extsBitmap s)
1520
1521 setExts :: (Int -> Int) -> P ()
1522 setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
1523
1524 setSrcLoc :: SrcLoc -> P ()
1525 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1526
1527 getSrcLoc :: P SrcLoc
1528 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1529
1530 setLastToken :: SrcSpan -> Int -> Int -> P ()
1531 setLastToken loc len line_len = P $ \s -> POk s { 
1532   last_loc=loc, 
1533   last_len=len,
1534   last_line_len=line_len 
1535 } ()
1536
1537 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
1538
1539 alexInputPrevChar :: AlexInput -> Char
1540 alexInputPrevChar (AI _ _ buf) = prevChar buf '\n'
1541
1542 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1543 alexGetChar (AI loc ofs s) 
1544   | atEnd s   = Nothing
1545   | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq` 
1546                 --trace (show (ord c)) $
1547                 Just (adj_c, (AI loc' ofs' s'))
1548   where (c,s') = nextChar s
1549         loc'   = advanceSrcLoc loc c
1550         ofs'   = advanceOffs c ofs
1551
1552         non_graphic     = '\x0'
1553         upper           = '\x1'
1554         lower           = '\x2'
1555         digit           = '\x3'
1556         symbol          = '\x4'
1557         space           = '\x5'
1558         other_graphic   = '\x6'
1559
1560         adj_c 
1561           | c <= '\x06' = non_graphic
1562           | c <= '\x7f' = c
1563           -- Alex doesn't handle Unicode, so when Unicode
1564           -- character is encoutered we output these values
1565           -- with the actual character value hidden in the state.
1566           | otherwise = 
1567                 case generalCategory c of
1568                   UppercaseLetter       -> upper
1569                   LowercaseLetter       -> lower
1570                   TitlecaseLetter       -> upper
1571                   ModifierLetter        -> other_graphic
1572                   OtherLetter           -> lower -- see #1103
1573                   NonSpacingMark        -> other_graphic
1574                   SpacingCombiningMark  -> other_graphic
1575                   EnclosingMark         -> other_graphic
1576                   DecimalNumber         -> digit
1577                   LetterNumber          -> other_graphic
1578                   OtherNumber           -> other_graphic
1579                   ConnectorPunctuation  -> symbol
1580                   DashPunctuation       -> symbol
1581                   OpenPunctuation       -> other_graphic
1582                   ClosePunctuation      -> other_graphic
1583                   InitialQuote          -> other_graphic
1584                   FinalQuote            -> other_graphic
1585                   OtherPunctuation      -> symbol
1586                   MathSymbol            -> symbol
1587                   CurrencySymbol        -> symbol
1588                   ModifierSymbol        -> symbol
1589                   OtherSymbol           -> symbol
1590                   Space                 -> space
1591                   _other                -> non_graphic
1592
1593 -- This version does not squash unicode characters, it is used when
1594 -- lexing strings.
1595 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1596 alexGetChar' (AI loc ofs s) 
1597   | atEnd s   = Nothing
1598   | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq` 
1599                 --trace (show (ord c)) $
1600                 Just (c, (AI loc' ofs' s'))
1601   where (c,s') = nextChar s
1602         loc'   = advanceSrcLoc loc c
1603         ofs'   = advanceOffs c ofs
1604
1605 advanceOffs :: Char -> Int -> Int
1606 advanceOffs '\n' _    = 0
1607 advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
1608 advanceOffs _    offs = offs + 1
1609
1610 getInput :: P AlexInput
1611 getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b)
1612
1613 setInput :: AlexInput -> P ()
1614 setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } ()
1615
1616 pushLexState :: Int -> P ()
1617 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1618
1619 popLexState :: P Int
1620 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1621
1622 getLexState :: P Int
1623 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1624
1625 -- for reasons of efficiency, flags indicating language extensions (eg,
1626 -- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
1627 -- integer
1628
1629 genericsBit, ffiBit, parrBit :: Int
1630 genericsBit = 0 -- {| and |}
1631 ffiBit     = 1
1632 parrBit    = 2
1633 arrowsBit  = 4
1634 thBit      = 5
1635 ipBit      = 6
1636 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1637 bangPatBit = 8  -- Tells the parser to understand bang-patterns
1638                 -- (doesn't affect the lexer)
1639 tyFamBit   = 9  -- indexed type families: 'family' keyword and kind sigs
1640 haddockBit = 10 -- Lex and parse Haddock comments
1641 magicHashBit = 11 -- "#" in both functions and operators
1642 kindSigsBit = 12 -- Kind signatures on type variables
1643 recursiveDoBit = 13 -- mdo
1644 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1645 unboxedTuplesBit = 15 -- (# and #)
1646 standaloneDerivingBit = 16 -- standalone instance deriving declarations
1647 transformComprehensionsBit = 17
1648 qqBit      = 18 -- enable quasiquoting
1649 inRulePragBit = 19
1650 rawTokenStreamBit = 20 -- producing a token stream with all comments included
1651 newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+)
1652
1653 genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1654 always           _     = True
1655 genericsEnabled  flags = testBit flags genericsBit
1656 ffiEnabled       flags = testBit flags ffiBit
1657 parrEnabled      flags = testBit flags parrBit
1658 arrowsEnabled    flags = testBit flags arrowsBit
1659 thEnabled        flags = testBit flags thBit
1660 ipEnabled        flags = testBit flags ipBit
1661 explicitForallEnabled flags = testBit flags explicitForallBit
1662 bangPatEnabled   flags = testBit flags bangPatBit
1663 tyFamEnabled     flags = testBit flags tyFamBit
1664 haddockEnabled   flags = testBit flags haddockBit
1665 magicHashEnabled flags = testBit flags magicHashBit
1666 kindSigsEnabled  flags = testBit flags kindSigsBit
1667 recursiveDoEnabled flags = testBit flags recursiveDoBit
1668 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1669 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1670 standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
1671 transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
1672 qqEnabled        flags = testBit flags qqBit
1673 inRulePrag       flags = testBit flags inRulePragBit
1674 rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit
1675 newQualOps       flags = testBit flags newQualOpsBit
1676 oldQualOps flags = not (newQualOps flags)
1677
1678 -- PState for parsing options pragmas
1679 --
1680 pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
1681 pragState dynflags buf loc =
1682   PState {
1683       buffer        = buf,
1684       messages      = emptyMessages,
1685       dflags        = dynflags,
1686       last_loc      = mkSrcSpan loc loc,
1687       last_offs     = 0,
1688       last_len      = 0,
1689       last_line_len = 0,
1690       loc           = loc,
1691       extsBitmap    = 0,
1692       context       = [],
1693       lex_state     = [bol, option_prags, 0]
1694     }
1695
1696
1697 -- create a parse state
1698 --
1699 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
1700 mkPState buf loc flags  = 
1701   PState {
1702       buffer          = buf,
1703       dflags        = flags,
1704       messages      = emptyMessages,
1705       last_loc      = mkSrcSpan loc loc,
1706       last_offs     = 0,
1707       last_len      = 0,
1708       last_line_len = 0,
1709       loc           = loc,
1710       extsBitmap    = fromIntegral bitmap,
1711       context       = [],
1712       lex_state     = [bol, 0]
1713         -- we begin in the layout state if toplev_layout is set
1714     }
1715     where
1716       bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
1717                .|. ffiBit       `setBitIf` dopt Opt_ForeignFunctionInterface flags
1718                .|. parrBit      `setBitIf` dopt Opt_PArr         flags
1719                .|. arrowsBit    `setBitIf` dopt Opt_Arrows       flags
1720                .|. thBit        `setBitIf` dopt Opt_TemplateHaskell flags
1721                .|. qqBit        `setBitIf` dopt Opt_QuasiQuotes flags
1722                .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
1723                .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
1724                .|. explicitForallBit `setBitIf` dopt Opt_LiberalTypeSynonyms flags
1725                .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
1726                .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
1727                .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
1728                .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
1729                .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
1730                .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
1731                .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
1732                .|. magicHashBit `setBitIf` dopt Opt_MagicHash    flags
1733                .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
1734                .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
1735                .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
1736                .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
1737                .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
1738                .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
1739                .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
1740                .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags
1741       --
1742       setBitIf :: Int -> Bool -> Int
1743       b `setBitIf` cond | cond      = bit b
1744                         | otherwise = 0
1745
1746 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
1747 addWarning option srcspan warning
1748  = P $ \s@PState{messages=(ws,es), dflags=d} ->
1749        let warning' = mkWarnMsg srcspan alwaysQualify warning
1750            ws' = if dopt option d then ws `snocBag` warning' else ws
1751        in POk s{messages=(ws', es)} ()
1752
1753 getMessages :: PState -> Messages
1754 getMessages PState{messages=ms} = ms
1755
1756 getContext :: P [LayoutContext]
1757 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1758
1759 setContext :: [LayoutContext] -> P ()
1760 setContext ctx = P $ \s -> POk s{context=ctx} ()
1761
1762 popContext :: P ()
1763 popContext = P $ \ s@(PState{ buffer = buf, context = ctx, 
1764                               last_len = len, last_loc = last_loc }) ->
1765   case ctx of
1766         (_:tl) -> POk s{ context = tl } ()
1767         []     -> PFailed last_loc (srcParseErr buf len)
1768
1769 -- Push a new layout context at the indentation of the last token read.
1770 -- This is only used at the outer level of a module when the 'module'
1771 -- keyword is missing.
1772 pushCurrentContext :: P ()
1773 pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } -> 
1774     POk s{context = Layout (offs-len) : ctx} ()
1775 --trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
1776
1777 getOffside :: P Ordering
1778 getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
1779                 let ord = case stk of
1780                         (Layout n:_) -> compare offs n
1781                         _            -> GT
1782                 in POk s ord
1783
1784 -- ---------------------------------------------------------------------------
1785 -- Construct a parse error
1786
1787 srcParseErr
1788   :: StringBuffer       -- current buffer (placed just after the last token)
1789   -> Int                -- length of the previous token
1790   -> Message
1791 srcParseErr buf len
1792   = hcat [ if null token 
1793              then ptext (sLit "parse error (possibly incorrect indentation)")
1794              else hcat [ptext (sLit "parse error on input "),
1795                         char '`', text token, char '\'']
1796     ]
1797   where token = lexemeToString (offsetBytes (-len) buf) len
1798
1799 -- Report a parse failure, giving the span of the previous token as
1800 -- the location of the error.  This is the entry point for errors
1801 -- detected during parsing.
1802 srcParseFail :: P a
1803 srcParseFail = P $ \PState{ buffer = buf, last_len = len,       
1804                             last_loc = last_loc } ->
1805     PFailed last_loc (srcParseErr buf len)
1806
1807 -- A lexical error is reported at a particular position in the source file,
1808 -- not over a token range.
1809 lexError :: String -> P a
1810 lexError str = do
1811   loc <- getSrcLoc
1812   (AI end _ buf) <- getInput
1813   reportLexError loc end buf str
1814
1815 -- -----------------------------------------------------------------------------
1816 -- This is the top-level function: called from the parser each time a
1817 -- new token is to be read from the input.
1818
1819 lexer :: (Located Token -> P a) -> P a
1820 lexer cont = do
1821   tok@(L _span _tok__) <- lexToken
1822 --  trace ("token: " ++ show tok__) $ do
1823   cont tok
1824
1825 lexToken :: P (Located Token)
1826 lexToken = do
1827   inp@(AI loc1 _ buf) <- getInput
1828   sc <- getLexState
1829   exts <- getExts
1830   case alexScanUser exts inp sc of
1831     AlexEOF -> do
1832         let span = mkSrcSpan loc1 loc1
1833         setLastToken span 0 0
1834         return (L span ITeof)
1835     AlexError (AI loc2 _ buf) ->
1836         reportLexError loc1 loc2 buf "lexical error"
1837     AlexSkip inp2 _ -> do
1838         setInput inp2
1839         lexToken
1840     AlexToken inp2@(AI end _ buf2) _ t -> do
1841         setInput inp2
1842         let span = mkSrcSpan loc1 end
1843         let bytes = byteDiff buf buf2
1844         span `seq` setLastToken span bytes bytes
1845         t span buf bytes
1846
1847 reportLexError loc1 loc2 buf str
1848   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
1849   | otherwise =
1850   let 
1851         c = fst (nextChar buf)
1852   in
1853   if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
1854     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
1855     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
1856
1857 lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
1858 lexTokenStream buf loc dflags = unP go initState
1859     where initState = mkPState buf loc (dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream)
1860           go = do
1861             ltok <- lexer return
1862             case ltok of
1863               L _ ITeof -> return []
1864               _ -> liftM (ltok:) go
1865 }