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