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