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