1486b64549271cb8484b15c88d6d505f04ea1d2e
[ghc.git] / compiler / parser / Lexer.x
1 -----------------------------------------------------------------------------
2 -- (c) The University of Glasgow, 2006
3 --
4 -- GHC's lexer.
5 --
6 -- This is a combination of an Alex-generated lexer from a regex
7 -- definition, with some hand-coded bits.
8 --
9 -- Completely accurate information about token-spans within the source
10 -- file is maintained.  Every token has a start and end RealSrcLoc
11 -- attached to it.
12 --
13 -----------------------------------------------------------------------------
14
15 --   ToDo / known bugs:
16 --    - parsing integers is a bit slow
17 --    - readRational is a bit slow
18 --
19 --   Known bugs, that were also in the previous version:
20 --    - M... should be 3 tokens, not 1.
21 --    - pragma-end should be only valid in a pragma
22
23 --   qualified operator NOTES.
24 --
25 --   - If M.(+) is a single lexeme, then..
26 --     - Probably (+) should be a single lexeme too, for consistency.
27 --       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.
28 --     - But we have to rule out reserved operators, otherwise (..) becomes
29 --       a different lexeme.
30 --     - Should we therefore also rule out reserved operators in the qualified
31 --       form?  This is quite difficult to achieve.  We don't do it for
32 --       qualified varids.
33
34 {
35 -- XXX The above flags turn off warnings in the generated code:
36 {-# LANGUAGE BangPatterns #-}
37 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
38 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
39 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
40 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
41 -- But alex still generates some code that causes the "lazy unlifted bindings"
42 -- warning, and old compilers don't know about it so we can't easily turn
43 -- it off, so for now we use the sledge hammer:
44 {-# OPTIONS_GHC -w #-}
45
46 {-# OPTIONS_GHC -funbox-strict-fields #-}
47
48 module Lexer (
49    Token(..), lexer, pragState, mkPState, PState(..),
50    P(..), ParseResult(..), getSrcLoc,
51    getPState, getDynFlags, withThisPackage,
52    failLocMsgP, failSpanMsgP, srcParseFail,
53    getMessages,
54    popContext, pushCurrentContext, setLastToken, setSrcLoc,
55    activeContext, nextIsEOF,
56    getLexState, popLexState, pushLexState,
57    extension, bangPatEnabled, datatypeContextsEnabled,
58    traditionalRecordSyntaxEnabled,
59    addWarning,
60    lexTokenStream
61   ) where
62
63 import Bag
64 import ErrUtils
65 import Outputable
66 import StringBuffer
67 import FastString
68 import SrcLoc
69 import UniqFM
70 import DynFlags
71 import Module
72 import Ctype
73 import BasicTypes       ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
74 import Util             ( readRational )
75
76 import Control.Monad
77 import Data.Bits
78 import Data.Char
79 import Data.List
80 import Data.Maybe
81 import Data.Map (Map)
82 import qualified Data.Map as Map
83 import Data.Ratio
84 import Data.Word
85 }
86
87 $unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
88 $whitechar   = [\ \n\r\f\v $unispace]
89 $white_no_nl = $whitechar # \n
90 $tab         = \t
91
92 $ascdigit  = 0-9
93 $unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
94 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
95 $digit     = [$ascdigit $unidigit]
96
97 $special   = [\(\)\,\;\[\]\`\{\}]
98 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
99 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
100 $symbol    = [$ascsymbol $unisymbol] # [$special \_\:\"\']
101
102 $unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
103 $asclarge  = [A-Z]
104 $large     = [$asclarge $unilarge]
105
106 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
107 $ascsmall  = [a-z]
108 $small     = [$ascsmall $unismall \_]
109
110 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
111 $graphic   = [$small $large $symbol $digit $special $unigraphic \:\"\']
112
113 $octit     = 0-7
114 $hexit     = [$decdigit A-F a-f]
115 $symchar   = [$symbol \:]
116 $nl        = [\n\r]
117 $idchar    = [$small $large $digit \']
118
119 $pragmachar = [$small $large $digit]
120
121 $docsym    = [\| \^ \* \$]
122
123 @varid     = $small $idchar*
124 @conid     = $large $idchar*
125
126 @varsym    = $symbol $symchar*
127 @consym    = \: $symchar*
128
129 @decimal     = $decdigit+
130 @octal       = $octit+
131 @hexadecimal = $hexit+
132 @exponent    = [eE] [\-\+]? @decimal
133
134 -- we support the hierarchical module name extension:
135 @qual = (@conid \.)+
136
137 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
138
139 -- normal signed numerical literals can only be explicitly negative,
140 -- not explicitly positive (contrast @exponent)
141 @negative = \-
142 @signed = @negative ?
143
144 haskell :-
145
146 -- everywhere: skip whitespace and comments
147 $white_no_nl+ ;
148 $tab+         { warn Opt_WarnTabs (text "Warning: Tab character") }
149
150 -- Everywhere: deal with nested comments.  We explicitly rule out
151 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
152 -- (this can happen even though pragmas will normally take precedence due to
153 -- longest-match, because pragmas aren't valid in every state, but comments
154 -- are). We also rule out nested Haddock comments, if the -haddock flag is
155 -- set.
156
157 "{-" / { isNormalComment } { nested_comment lexToken }
158
159 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
160 -- more dashes followed by a symbol should be parsed as a varsym, so we
161 -- have to exclude those.
162
163 -- Since Haddock comments aren't valid in every state, we need to rule them
164 -- out here.
165
166 -- The following two rules match comments that begin with two dashes, but
167 -- continue with a different character. The rules test that this character
168 -- is not a symbol (in which case we'd have a varsym), and that it's not a
169 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
170 -- have a Haddock comment). The rules then munch the rest of the line.
171
172 "-- " ~[$docsym \#] .* { lineCommentToken }
173 "--" [^$symbol : \ ] .* { lineCommentToken }
174
175 -- Next, match Haddock comments if no -haddock flag
176
177 "-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }
178
179 -- Now, when we've matched comments that begin with 2 dashes and continue
180 -- with a different character, we need to match comments that begin with three
181 -- or more dashes (which clearly can't be Haddock comments). We only need to
182 -- make sure that the first non-dash character isn't a symbol, and munch the
183 -- rest of the line.
184
185 "---"\-* [^$symbol :] .* { lineCommentToken }
186
187 -- Since the previous rules all match dashes followed by at least one
188 -- character, we also need to match a whole line filled with just dashes.
189
190 "--"\-* / { atEOL } { lineCommentToken }
191
192 -- We need this rule since none of the other single line comment rules
193 -- actually match this case.
194
195 "-- " / { atEOL } { lineCommentToken }
196
197 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
198 -- blank lines) until we find a non-whitespace character, then do layout
199 -- processing.
200 --
201 -- One slight wibble here: what if the line begins with {-#? In
202 -- theory, we have to lex the pragma to see if it's one we recognise,
203 -- and if it is, then we backtrack and do_bol, otherwise we treat it
204 -- as a nested comment.  We don't bother with this: if the line begins
205 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
206 <bol> {
207   \n                                    ;
208   ^\# (line)?                           { begin line_prag1 }
209   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
210   ^\# \! .* \n                          ; -- #!, for scripts
211   ()                                    { do_bol }
212 }
213
214 -- after a layout keyword (let, where, do, of), we begin a new layout
215 -- context if the curly brace is missing.
216 -- Careful! This stuff is quite delicate.
217 <layout, layout_do> {
218   \{ / { notFollowedBy '-' }            { hopefully_open_brace }
219         -- we might encounter {-# here, but {- has been handled already
220   \n                                    ;
221   ^\# (line)?                           { begin line_prag1 }
222 }
223
224 -- do is treated in a subtly different way, see new_layout_context
225 <layout>    ()                          { new_layout_context True }
226 <layout_do> ()                          { new_layout_context False }
227
228 -- after a new layout context which was found to be to the left of the
229 -- previous context, we have generated a '{' token, and we now need to
230 -- generate a matching '}' token.
231 <layout_left>  ()                       { do_layout_left }
232
233 <0,option_prags> \n                     { begin bol }
234
235 "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }
236                                 { dispatch_pragmas linePrags }
237
238 -- single-line line pragmas, of the form
239 --    # <line> "<file>" <extra-stuff> \n
240 <line_prag1> $decdigit+                 { setLine line_prag1a }
241 <line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }
242 <line_prag1b> .*                        { pop }
243
244 -- Haskell-style line pragmas, of the form
245 --    {-# LINE <line> "<file>" #-}
246 <line_prag2> $decdigit+                 { setLine line_prag2a }
247 <line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }
248 <line_prag2b> "#-}"|"-}"                { pop }
249    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
250    -- with older versions of GHC which generated these.
251
252 <0,option_prags> {
253   "{-#" $whitechar* $pragmachar+
254         $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }
255                                  { dispatch_pragmas twoWordPrags }
256
257   "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }
258                                  { dispatch_pragmas oneWordPrags }
259
260   -- We ignore all these pragmas, but don't generate a warning for them
261   "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }
262                                  { dispatch_pragmas ignoredPrags }
263
264   -- ToDo: should only be valid inside a pragma:
265   "#-}"                          { endPrag }
266 }
267
268 <option_prags> {
269   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
270                                    { dispatch_pragmas fileHeaderPrags }
271
272   "-- #"                           { multiline_doc_comment }
273 }
274
275 <0> {
276   -- In the "0" mode we ignore these pragmas
277   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
278                      { nested_comment lexToken }
279 }
280
281 <0> {
282   "-- #" .* { lineCommentToken }
283 }
284
285 <0,option_prags> {
286   "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
287                     (nested_comment lexToken) }
288 }
289
290 -- '0' state: ordinary lexemes
291
292 -- Haddock comments
293
294 <0,option_prags> {
295   "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
296   "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
297 }
298
299 -- "special" symbols
300
301 <0> {
302   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
303   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
304 }
305
306 <0> {
307   "[|"      / { ifExtension thEnabled } { token ITopenExpQuote }
308   "[e|"     / { ifExtension thEnabled } { token ITopenExpQuote }
309   "[p|"     / { ifExtension thEnabled } { token ITopenPatQuote }
310   "[d|"     / { ifExtension thEnabled } { layout_token ITopenDecQuote }
311   "[t|"     / { ifExtension thEnabled } { token ITopenTypQuote }
312   "|]"      / { ifExtension thEnabled } { token ITcloseQuote }
313   \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
314   "$("      / { ifExtension thEnabled } { token ITparenEscape }
315
316 -- For backward compatibility, accept the old dollar syntax
317   "[$" @varid "|"  / { ifExtension qqEnabled }
318                      { lex_quasiquote_tok }
319
320   "[" @varid "|"  / { ifExtension qqEnabled }
321                      { lex_quasiquote_tok }
322 }
323
324 <0> {
325   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
326                                         { special IToparenbar }
327   "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
328 }
329
330 <0> {
331   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
332 }
333
334 <0> {
335   "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
336          { token IToubxparen }
337   "#)" / { ifExtension unboxedTuplesEnabled }
338          { token ITcubxparen }
339 }
340
341 <0,option_prags> {
342   \(                                    { special IToparen }
343   \)                                    { special ITcparen }
344   \[                                    { special ITobrack }
345   \]                                    { special ITcbrack }
346   \,                                    { special ITcomma }
347   \;                                    { special ITsemi }
348   \`                                    { special ITbackquote }
349
350   \{                                    { open_brace }
351   \}                                    { close_brace }
352 }
353
354 <0,option_prags> {
355   @qual @varid                  { idtoken qvarid }
356   @qual @conid                  { idtoken qconid }
357   @varid                        { varid }
358   @conid                        { idtoken conid }
359 }
360
361 <0> {
362   @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
363   @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
364   @varid "#"+       / { ifExtension magicHashEnabled } { varid }
365   @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
366 }
367
368 -- ToDo: - move `var` and (sym) into lexical syntax?
369 --       - remove backquote from $special?
370 <0> {
371   @qual @varsym                                    { idtoken qvarsym }
372   @qual @consym                                    { idtoken qconsym }
373   @varsym                                          { varsym }
374   @consym                                          { consym }
375 }
376
377 -- For the normal boxed literals we need to be careful
378 -- when trying to be close to Haskell98
379 <0> {
380   -- Normal integral literals (:: Num a => a, from Integer)
381   @decimal           { tok_num positive 0 0 decimal }
382   0[oO] @octal       { tok_num positive 2 2 octal }
383   0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
384
385   -- Normal rational literals (:: Fractional a => a, from Rational)
386   @floating_point    { strtoken tok_float }
387 }
388
389 <0> {
390   -- Unboxed ints (:: Int#) and words (:: Word#)
391   -- It's simpler (and faster?) to give separate cases to the negatives,
392   -- especially considering octal/hexadecimal prefixes.
393   @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
394   0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
395   0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
396   @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
397   @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
398   @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
399
400   @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
401   0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
402   0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
403
404   -- Unboxed floats and doubles (:: Float#, :: Double#)
405   -- prim_{float,double} work with signed literals
406   @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
407   @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
408 }
409
410 -- Strings and chars are lexed by hand-written code.  The reason is
411 -- that even if we recognise the string or char here in the regex
412 -- lexer, we would still have to parse the string afterward in order
413 -- to convert it to a String.
414 <0> {
415   \'                            { lex_char_tok }
416   \"                            { lex_string_tok }
417 }
418
419 {
420 -- -----------------------------------------------------------------------------
421 -- The token type
422
423 data Token
424   = ITas                        -- Haskell keywords
425   | ITcase
426   | ITclass
427   | ITdata
428   | ITdefault
429   | ITderiving
430   | ITdo
431   | ITelse
432   | IThiding
433   | ITif
434   | ITimport
435   | ITin
436   | ITinfix
437   | ITinfixl
438   | ITinfixr
439   | ITinstance
440   | ITlet
441   | ITmodule
442   | ITnewtype
443   | ITof
444   | ITqualified
445   | ITthen
446   | ITtype
447   | ITwhere
448   | ITscc                       -- ToDo: remove (we use {-# SCC "..." #-} now)
449
450   | ITforall                    -- GHC extension keywords
451   | ITforeign
452   | ITexport
453   | ITlabel
454   | ITdynamic
455   | ITsafe
456   | ITinterruptible
457   | ITunsafe
458   | ITstdcallconv
459   | ITccallconv
460   | ITprimcallconv
461   | ITmdo
462   | ITfamily
463   | ITgroup
464   | ITby
465   | ITusing
466
467   -- Pragmas
468   | ITinline_prag InlineSpec RuleMatchInfo
469   | ITspec_prag                 -- SPECIALISE
470   | ITspec_inline_prag Bool     -- SPECIALISE INLINE (or NOINLINE)
471   | ITsource_prag
472   | ITrules_prag
473   | ITwarning_prag
474   | ITdeprecated_prag
475   | ITline_prag
476   | ITscc_prag
477   | ITgenerated_prag
478   | ITcore_prag                 -- hdaume: core annotations
479   | ITunpack_prag
480   | ITnounpack_prag
481   | ITann_prag
482   | ITclose_prag
483   | IToptions_prag String
484   | ITinclude_prag String
485   | ITlanguage_prag
486   | ITvect_prag
487   | ITvect_scalar_prag
488   | ITnovect_prag
489
490   | ITdotdot                    -- reserved symbols
491   | ITcolon
492   | ITdcolon
493   | ITequal
494   | ITlam
495   | ITvbar
496   | ITlarrow
497   | ITrarrow
498   | ITat
499   | ITtilde
500   | ITtildehsh
501   | ITdarrow
502   | ITminus
503   | ITbang
504   | ITstar
505   | ITdot
506
507   | ITbiglam                    -- GHC-extension symbols
508
509   | ITocurly                    -- special symbols
510   | ITccurly
511   | ITocurlybar                 -- {|, for type applications
512   | ITccurlybar                 -- |}, for type applications
513   | ITvocurly
514   | ITvccurly
515   | ITobrack
516   | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays
517   | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays
518   | ITcbrack
519   | IToparen
520   | ITcparen
521   | IToubxparen
522   | ITcubxparen
523   | ITsemi
524   | ITcomma
525   | ITunderscore
526   | ITbackquote
527   | ITsimpleQuote               --  '
528
529   | ITvarid   FastString        -- identifiers
530   | ITconid   FastString
531   | ITvarsym  FastString
532   | ITconsym  FastString
533   | ITqvarid  (FastString,FastString)
534   | ITqconid  (FastString,FastString)
535   | ITqvarsym (FastString,FastString)
536   | ITqconsym (FastString,FastString)
537   | ITprefixqvarsym (FastString,FastString)
538   | ITprefixqconsym (FastString,FastString)
539
540   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
541
542   | ITchar       Char
543   | ITstring     FastString
544   | ITinteger    Integer
545   | ITrational   FractionalLit
546
547   | ITprimchar   Char
548   | ITprimstring FastString
549   | ITprimint    Integer
550   | ITprimword   Integer
551   | ITprimfloat  FractionalLit
552   | ITprimdouble FractionalLit
553
554   -- Template Haskell extension tokens
555   | ITopenExpQuote              --  [| or [e|
556   | ITopenPatQuote              --  [p|
557   | ITopenDecQuote              --  [d|
558   | ITopenTypQuote              --  [t|
559   | ITcloseQuote                --  |]
560   | ITidEscape   FastString     --  $x
561   | ITparenEscape               --  $(
562   | ITtyQuote                   --  ''
563   | ITquasiQuote (FastString,FastString,RealSrcSpan) --  [:...|...|]
564
565   -- Arrow notation extension
566   | ITproc
567   | ITrec
568   | IToparenbar                 --  (|
569   | ITcparenbar                 --  |)
570   | ITlarrowtail                --  -<
571   | ITrarrowtail                --  >-
572   | ITLarrowtail                --  -<<
573   | ITRarrowtail                --  >>-
574
575   | ITunknown String            -- Used when the lexer can't make sense of it
576   | ITeof                       -- end of file token
577
578   -- Documentation annotations
579   | ITdocCommentNext  String     -- something beginning '-- |'
580   | ITdocCommentPrev  String     -- something beginning '-- ^'
581   | ITdocCommentNamed String     -- something beginning '-- $'
582   | ITdocSection      Int String -- a section heading
583   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
584   | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
585   | ITlineComment     String     -- comment starting by "--"
586   | ITblockComment    String     -- comment in {- -}
587
588   deriving Show
589
590 -- the bitmap provided as the third component indicates whether the
591 -- corresponding extension keyword is valid under the extension options
592 -- provided to the compiler; if the extension corresponding to *any* of the
593 -- bits set in the bitmap is enabled, the keyword is valid (this setup
594 -- facilitates using a keyword in two different extensions that can be
595 -- activated independently)
596 --
597 reservedWordsFM :: UniqFM (Token, Int)
598 reservedWordsFM = listToUFM $
599     map (\(x, y, z) -> (mkFastString x, (y, z)))
600         [( "_",              ITunderscore,    0 ),
601          ( "as",             ITas,            0 ),
602          ( "case",           ITcase,          0 ),
603          ( "class",          ITclass,         0 ),
604          ( "data",           ITdata,          0 ),
605          ( "default",        ITdefault,       0 ),
606          ( "deriving",       ITderiving,      0 ),
607          ( "do",             ITdo,            0 ),
608          ( "else",           ITelse,          0 ),
609          ( "hiding",         IThiding,        0 ),
610          ( "if",             ITif,            0 ),
611          ( "import",         ITimport,        0 ),
612          ( "in",             ITin,            0 ),
613          ( "infix",          ITinfix,         0 ),
614          ( "infixl",         ITinfixl,        0 ),
615          ( "infixr",         ITinfixr,        0 ),
616          ( "instance",       ITinstance,      0 ),
617          ( "let",            ITlet,           0 ),
618          ( "module",         ITmodule,        0 ),
619          ( "newtype",        ITnewtype,       0 ),
620          ( "of",             ITof,            0 ),
621          ( "qualified",      ITqualified,     0 ),
622          ( "then",           ITthen,          0 ),
623          ( "type",           ITtype,          0 ),
624          ( "where",          ITwhere,         0 ),
625          ( "_scc_",          ITscc,           0 ),            -- ToDo: remove
626
627          ( "forall",         ITforall,        bit explicitForallBit .|.
628                                               bit inRulePragBit),
629          ( "mdo",            ITmdo,           bit recursiveDoBit),
630          ( "family",         ITfamily,        bit tyFamBit),
631          ( "group",          ITgroup,         bit transformComprehensionsBit),
632          ( "by",             ITby,            bit transformComprehensionsBit),
633          ( "using",          ITusing,         bit transformComprehensionsBit),
634
635          ( "foreign",        ITforeign,       bit ffiBit),
636          ( "export",         ITexport,        bit ffiBit),
637          ( "label",          ITlabel,         bit ffiBit),
638          ( "dynamic",        ITdynamic,       bit ffiBit),
639          ( "safe",           ITsafe,          bit ffiBit .|.
640                                               bit safeHaskellBit),
641          ( "interruptible",  ITinterruptible, bit interruptibleFfiBit),
642          ( "unsafe",         ITunsafe,        bit ffiBit),
643          ( "stdcall",        ITstdcallconv,   bit ffiBit),
644          ( "ccall",          ITccallconv,     bit ffiBit),
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         Message         -- 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 getDynFlags :: P DynFlags
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 parrBit :: Int
1758 parrBit = 3
1759 arrowsBit :: Int
1760 arrowsBit  = 4
1761 thBit :: Int
1762 thBit = 5
1763 ipBit :: Int
1764 ipBit = 6
1765 explicitForallBit :: Int
1766 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1767 bangPatBit :: Int
1768 bangPatBit = 8  -- Tells the parser to understand bang-patterns
1769                 -- (doesn't affect the lexer)
1770 tyFamBit :: Int
1771 tyFamBit = 9    -- indexed type families: 'family' keyword and kind sigs
1772 haddockBit :: Int
1773 haddockBit = 10 -- Lex and parse Haddock comments
1774 magicHashBit :: Int
1775 magicHashBit = 11 -- "#" in both functions and operators
1776 kindSigsBit :: Int
1777 kindSigsBit = 12 -- Kind signatures on type variables
1778 recursiveDoBit :: Int
1779 recursiveDoBit = 13 -- mdo
1780 unicodeSyntaxBit :: Int
1781 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1782 unboxedTuplesBit :: Int
1783 unboxedTuplesBit = 15 -- (# and #)
1784 datatypeContextsBit :: Int
1785 datatypeContextsBit = 16
1786 transformComprehensionsBit :: Int
1787 transformComprehensionsBit = 17
1788 qqBit :: Int
1789 qqBit = 18 -- enable quasiquoting
1790 inRulePragBit :: Int
1791 inRulePragBit = 19
1792 rawTokenStreamBit :: Int
1793 rawTokenStreamBit = 20 -- producing a token stream with all comments included
1794 recBit :: Int
1795 recBit = 22 -- rec
1796 alternativeLayoutRuleBit :: Int
1797 alternativeLayoutRuleBit = 23
1798 relaxedLayoutBit :: Int
1799 relaxedLayoutBit = 24
1800 nondecreasingIndentationBit :: Int
1801 nondecreasingIndentationBit = 25
1802 safeHaskellBit :: Int
1803 safeHaskellBit = 26
1804 traditionalRecordSyntaxBit :: Int
1805 traditionalRecordSyntaxBit = 27
1806
1807 always :: Int -> Bool
1808 always           _     = True
1809 parrEnabled :: Int -> Bool
1810 parrEnabled      flags = testBit flags parrBit
1811 arrowsEnabled :: Int -> Bool
1812 arrowsEnabled    flags = testBit flags arrowsBit
1813 thEnabled :: Int -> Bool
1814 thEnabled        flags = testBit flags thBit
1815 ipEnabled :: Int -> Bool
1816 ipEnabled        flags = testBit flags ipBit
1817 explicitForallEnabled :: Int -> Bool
1818 explicitForallEnabled flags = testBit flags explicitForallBit
1819 bangPatEnabled :: Int -> Bool
1820 bangPatEnabled   flags = testBit flags bangPatBit
1821 -- tyFamEnabled :: Int -> Bool
1822 -- tyFamEnabled     flags = testBit flags tyFamBit
1823 haddockEnabled :: Int -> Bool
1824 haddockEnabled   flags = testBit flags haddockBit
1825 magicHashEnabled :: Int -> Bool
1826 magicHashEnabled flags = testBit flags magicHashBit
1827 -- kindSigsEnabled :: Int -> Bool
1828 -- kindSigsEnabled  flags = testBit flags kindSigsBit
1829 unicodeSyntaxEnabled :: Int -> Bool
1830 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1831 unboxedTuplesEnabled :: Int -> Bool
1832 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1833 datatypeContextsEnabled :: Int -> Bool
1834 datatypeContextsEnabled flags = testBit flags datatypeContextsBit
1835 qqEnabled :: Int -> Bool
1836 qqEnabled        flags = testBit flags qqBit
1837 -- inRulePrag :: Int -> Bool
1838 -- inRulePrag       flags = testBit flags inRulePragBit
1839 rawTokenStreamEnabled :: Int -> Bool
1840 rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit
1841 alternativeLayoutRule :: Int -> Bool
1842 alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit
1843 relaxedLayout :: Int -> Bool
1844 relaxedLayout flags = testBit flags relaxedLayoutBit
1845 nondecreasingIndentation :: Int -> Bool
1846 nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit
1847 traditionalRecordSyntaxEnabled :: Int -> Bool
1848 traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit
1849
1850 -- PState for parsing options pragmas
1851 --
1852 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
1853 pragState dynflags buf loc = (mkPState dynflags buf loc) {
1854                                  lex_state = [bol, option_prags, 0]
1855                              }
1856
1857 -- create a parse state
1858 --
1859 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
1860 mkPState flags buf loc =
1861   PState {
1862       buffer        = buf,
1863       dflags        = flags,
1864       messages      = emptyMessages,
1865       last_loc      = mkRealSrcSpan loc loc,
1866       last_len      = 0,
1867       loc           = loc,
1868       extsBitmap    = fromIntegral bitmap,
1869       context       = [],
1870       lex_state     = [bol, 0],
1871       srcfiles      = [],
1872       alr_pending_implicit_tokens = [],
1873       alr_next_token = Nothing,
1874       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
1875       alr_context = [],
1876       alr_expecting_ocurly = Nothing,
1877       alr_justClosedExplicitLetBlock = False
1878     }
1879     where
1880       bitmap =     ffiBit                      `setBitIf` xopt Opt_ForeignFunctionInterface flags
1881                .|. interruptibleFfiBit         `setBitIf` xopt Opt_InterruptibleFFI         flags
1882                .|. parrBit                     `setBitIf` xopt Opt_ParallelArrays           flags
1883                .|. arrowsBit                   `setBitIf` xopt Opt_Arrows                   flags
1884                .|. thBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
1885                .|. qqBit                       `setBitIf` xopt Opt_QuasiQuotes              flags
1886                .|. ipBit                       `setBitIf` xopt Opt_ImplicitParams           flags
1887                .|. explicitForallBit           `setBitIf` xopt Opt_ExplicitForAll           flags
1888                .|. bangPatBit                  `setBitIf` xopt Opt_BangPatterns             flags
1889                .|. tyFamBit                    `setBitIf` xopt Opt_TypeFamilies             flags
1890                .|. haddockBit                  `setBitIf` dopt Opt_Haddock                  flags
1891                .|. magicHashBit                `setBitIf` xopt Opt_MagicHash                flags
1892                .|. kindSigsBit                 `setBitIf` xopt Opt_KindSignatures           flags
1893                .|. recursiveDoBit              `setBitIf` xopt Opt_RecursiveDo              flags
1894                .|. recBit                      `setBitIf` xopt Opt_DoRec                    flags
1895                .|. recBit                      `setBitIf` xopt Opt_Arrows                   flags
1896                .|. unicodeSyntaxBit            `setBitIf` xopt Opt_UnicodeSyntax            flags
1897                .|. unboxedTuplesBit            `setBitIf` xopt Opt_UnboxedTuples            flags
1898                .|. datatypeContextsBit         `setBitIf` xopt Opt_DatatypeContexts         flags
1899                .|. transformComprehensionsBit  `setBitIf` xopt Opt_TransformListComp        flags
1900                .|. transformComprehensionsBit  `setBitIf` xopt Opt_MonadComprehensions      flags
1901                .|. rawTokenStreamBit           `setBitIf` dopt Opt_KeepRawTokenStream       flags
1902                .|. alternativeLayoutRuleBit    `setBitIf` xopt Opt_AlternativeLayoutRule    flags
1903                .|. relaxedLayoutBit            `setBitIf` xopt Opt_RelaxedLayout            flags
1904                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
1905                .|. safeHaskellBit              `setBitIf` safeImportsOn                     flags
1906                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
1907       --
1908       setBitIf :: Int -> Bool -> Int
1909       b `setBitIf` cond | cond      = bit b
1910                         | otherwise = 0
1911
1912 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
1913 addWarning option srcspan warning
1914  = P $ \s@PState{messages=(ws,es), dflags=d} ->
1915        let warning' = mkWarnMsg srcspan alwaysQualify warning
1916            ws' = if wopt option d then ws `snocBag` warning' else ws
1917        in POk s{messages=(ws', es)} ()
1918
1919 getMessages :: PState -> Messages
1920 getMessages PState{messages=ms} = ms
1921
1922 getContext :: P [LayoutContext]
1923 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1924
1925 setContext :: [LayoutContext] -> P ()
1926 setContext ctx = P $ \s -> POk s{context=ctx} ()
1927
1928 popContext :: P ()
1929 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1930                               last_len = len, last_loc = last_loc }) ->
1931   case ctx of
1932         (_:tl) -> POk s{ context = tl } ()
1933         []     -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
1934
1935 -- Push a new layout context at the indentation of the last token read.
1936 -- This is only used at the outer level of a module when the 'module'
1937 -- keyword is missing.
1938 pushCurrentContext :: P ()
1939 pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } ->
1940     POk s{context = Layout (srcSpanStartCol loc) : ctx} ()
1941
1942 getOffside :: P Ordering
1943 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
1944                 let offs = srcSpanStartCol loc in
1945                 let ord = case stk of
1946                         (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
1947                                         compare offs n
1948                         _            -> GT
1949                 in POk s ord
1950
1951 -- ---------------------------------------------------------------------------
1952 -- Construct a parse error
1953
1954 srcParseErr
1955   :: StringBuffer       -- current buffer (placed just after the last token)
1956   -> Int                -- length of the previous token
1957   -> Message
1958 srcParseErr buf len
1959   = hcat [ if null token
1960              then ptext (sLit "parse error (possibly incorrect indentation)")
1961              else hcat [ptext (sLit "parse error on input "),
1962                         char '`', text token, char '\'']
1963     ]
1964   where token = lexemeToString (offsetBytes (-len) buf) len
1965
1966 -- Report a parse failure, giving the span of the previous token as
1967 -- the location of the error.  This is the entry point for errors
1968 -- detected during parsing.
1969 srcParseFail :: P a
1970 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1971                             last_loc = last_loc } ->
1972     PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
1973
1974 -- A lexical error is reported at a particular position in the source file,
1975 -- not over a token range.
1976 lexError :: String -> P a
1977 lexError str = do
1978   loc <- getSrcLoc
1979   (AI end buf) <- getInput
1980   reportLexError loc end buf str
1981
1982 -- -----------------------------------------------------------------------------
1983 -- This is the top-level function: called from the parser each time a
1984 -- new token is to be read from the input.
1985
1986 lexer :: (Located Token -> P a) -> P a
1987 lexer cont = do
1988   alr <- extension alternativeLayoutRule
1989   let lexTokenFun = if alr then lexTokenAlr else lexToken
1990   (L span tok) <- lexTokenFun
1991   --trace ("token: " ++ show tok) $ do
1992   cont (L (RealSrcSpan span) tok)
1993
1994 lexTokenAlr :: P (RealLocated Token)
1995 lexTokenAlr = do mPending <- popPendingImplicitToken
1996                  t <- case mPending of
1997                       Nothing ->
1998                           do mNext <- popNextToken
1999                              t <- case mNext of
2000                                   Nothing -> lexToken
2001                                   Just next -> return next
2002                              alternativeLayoutRuleToken t
2003                       Just t ->
2004                           return t
2005                  setAlrLastLoc (getLoc t)
2006                  case unLoc t of
2007                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2008                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2009                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2010                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2011                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2012                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2013                      _       -> return ()
2014                  return t
2015
2016 alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
2017 alternativeLayoutRuleToken t
2018     = do context <- getALRContext
2019          lastLoc <- getAlrLastLoc
2020          mExpectingOCurly <- getAlrExpectingOCurly
2021          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2022          setJustClosedExplicitLetBlock False
2023          dflags <- getDynFlags
2024          let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
2025              thisLoc = getLoc t
2026              thisCol = srcSpanStartCol thisLoc
2027              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
2028          case (unLoc t, context, mExpectingOCurly) of
2029              -- This case handles a GHC extension to the original H98
2030              -- layout rule...
2031              (ITocurly, _, Just alrLayout) ->
2032                  do setAlrExpectingOCurly Nothing
2033                     let isLet = case alrLayout of
2034                                 ALRLayoutLet -> True
2035                                 _ -> False
2036                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2037                     return t
2038              -- ...and makes this case unnecessary
2039              {-
2040              -- I think our implicit open-curly handling is slightly
2041              -- different to John's, in how it interacts with newlines
2042              -- and "in"
2043              (ITocurly, _, Just _) ->
2044                  do setAlrExpectingOCurly Nothing
2045                     setNextToken t
2046                     lexTokenAlr
2047              -}
2048              (_, ALRLayout _ col : ls, Just expectingOCurly)
2049               | (thisCol > col) ||
2050                 (thisCol == col &&
2051                  isNonDecreasingIntentation expectingOCurly) ->
2052                  do setAlrExpectingOCurly Nothing
2053                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2054                     setNextToken t
2055                     return (L thisLoc ITocurly)
2056               | otherwise ->
2057                  do setAlrExpectingOCurly Nothing
2058                     setPendingImplicitTokens [L lastLoc ITccurly]
2059                     setNextToken t
2060                     return (L lastLoc ITocurly)
2061              (_, _, Just expectingOCurly) ->
2062                  do setAlrExpectingOCurly Nothing
2063                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2064                     setNextToken t
2065                     return (L thisLoc ITocurly)
2066              -- We do the [] cases earlier than in the spec, as we
2067              -- have an actual EOF token
2068              (ITeof, ALRLayout _ _ : ls, _) ->
2069                  do setALRContext ls
2070                     setNextToken t
2071                     return (L thisLoc ITccurly)
2072              (ITeof, _, _) ->
2073                  return t
2074              -- the other ITeof case omitted; general case below covers it
2075              (ITin, _, _)
2076               | justClosedExplicitLetBlock ->
2077                  return t
2078              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2079               | newLine ->
2080                  do setPendingImplicitTokens [t]
2081                     setALRContext ls
2082                     return (L thisLoc ITccurly)
2083              -- This next case is to handle a transitional issue:
2084              (ITwhere, ALRLayout _ col : ls, _)
2085               | newLine && thisCol == col && transitional ->
2086                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2087                                (RealSrcSpan thisLoc)
2088                                (transitionalAlternativeLayoutWarning
2089                                     "`where' clause at the same depth as implicit layout block")
2090                     setALRContext ls
2091                     setNextToken t
2092                     -- Note that we use lastLoc, as we may need to close
2093                     -- more layouts, or give a semicolon
2094                     return (L lastLoc ITccurly)
2095              -- This next case is to handle a transitional issue:
2096              (ITvbar, ALRLayout _ col : ls, _)
2097               | newLine && thisCol == col && transitional ->
2098                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2099                                (RealSrcSpan thisLoc)
2100                                (transitionalAlternativeLayoutWarning
2101                                     "`|' at the same depth as implicit layout block")
2102                     setALRContext ls
2103                     setNextToken t
2104                     -- Note that we use lastLoc, as we may need to close
2105                     -- more layouts, or give a semicolon
2106                     return (L lastLoc ITccurly)
2107              (_, ALRLayout _ col : ls, _)
2108               | newLine && thisCol == col ->
2109                  do setNextToken t
2110                     return (L thisLoc ITsemi)
2111               | newLine && thisCol < col ->
2112                  do setALRContext ls
2113                     setNextToken t
2114                     -- Note that we use lastLoc, as we may need to close
2115                     -- more layouts, or give a semicolon
2116                     return (L lastLoc ITccurly)
2117              -- We need to handle close before open, as 'then' is both
2118              -- an open and a close
2119              (u, _, _)
2120               | isALRclose u ->
2121                  case context of
2122                  ALRLayout _ _ : ls ->
2123                      do setALRContext ls
2124                         setNextToken t
2125                         return (L thisLoc ITccurly)
2126                  ALRNoLayout _ isLet : ls ->
2127                      do let ls' = if isALRopen u
2128                                      then ALRNoLayout (containsCommas u) False : ls
2129                                      else ls
2130                         setALRContext ls'
2131                         when isLet $ setJustClosedExplicitLetBlock True
2132                         return t
2133                  [] ->
2134                      do let ls = if isALRopen u
2135                                     then [ALRNoLayout (containsCommas u) False]
2136                                     else ls
2137                         setALRContext ls
2138                         -- XXX This is an error in John's code, but
2139                         -- it looks reachable to me at first glance
2140                         return t
2141              (u, _, _)
2142               | isALRopen u ->
2143                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2144                     return t
2145              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2146                  do setALRContext ls
2147                     setPendingImplicitTokens [t]
2148                     return (L thisLoc ITccurly)
2149              (ITin, ALRLayout _ _ : ls, _) ->
2150                  do setALRContext ls
2151                     setNextToken t
2152                     return (L thisLoc ITccurly)
2153              -- the other ITin case omitted; general case below covers it
2154              (ITcomma, ALRLayout _ _ : ls, _)
2155               | topNoLayoutContainsCommas ls ->
2156                  do setALRContext ls
2157                     setNextToken t
2158                     return (L thisLoc ITccurly)
2159              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2160                  do setALRContext ls
2161                     setPendingImplicitTokens [t]
2162                     return (L thisLoc ITccurly)
2163              -- the other ITwhere case omitted; general case below covers it
2164              (_, _, _) -> return t
2165
2166 transitionalAlternativeLayoutWarning :: String -> SDoc
2167 transitionalAlternativeLayoutWarning msg
2168     = text "transitional layout will not be accepted in the future:"
2169    $$ text msg
2170
2171 isALRopen :: Token -> Bool
2172 isALRopen ITcase        = True
2173 isALRopen ITif          = True
2174 isALRopen ITthen        = True
2175 isALRopen IToparen      = True
2176 isALRopen ITobrack      = True
2177 isALRopen ITocurly      = True
2178 -- GHC Extensions:
2179 isALRopen IToubxparen   = True
2180 isALRopen ITparenEscape = True
2181 isALRopen _             = False
2182
2183 isALRclose :: Token -> Bool
2184 isALRclose ITof     = True
2185 isALRclose ITthen   = True
2186 isALRclose ITelse   = True
2187 isALRclose ITcparen = True
2188 isALRclose ITcbrack = True
2189 isALRclose ITccurly = True
2190 -- GHC Extensions:
2191 isALRclose ITcubxparen = True
2192 isALRclose _        = False
2193
2194 isNonDecreasingIntentation :: ALRLayout -> Bool
2195 isNonDecreasingIntentation ALRLayoutDo = True
2196 isNonDecreasingIntentation _           = False
2197
2198 containsCommas :: Token -> Bool
2199 containsCommas IToparen = True
2200 containsCommas ITobrack = True
2201 -- John doesn't have {} as containing commas, but records contain them,
2202 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2203 -- (defaultInstallDirs).
2204 containsCommas ITocurly = True
2205 -- GHC Extensions:
2206 containsCommas IToubxparen = True
2207 containsCommas _        = False
2208
2209 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2210 topNoLayoutContainsCommas [] = False
2211 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2212 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2213
2214 lexToken :: P (RealLocated Token)
2215 lexToken = do
2216   inp@(AI loc1 buf) <- getInput
2217   sc <- getLexState
2218   exts <- getExts
2219   case alexScanUser exts inp sc of
2220     AlexEOF -> do
2221         let span = mkRealSrcSpan loc1 loc1
2222         setLastToken span 0
2223         return (L span ITeof)
2224     AlexError (AI loc2 buf) ->
2225         reportLexError loc1 loc2 buf "lexical error"
2226     AlexSkip inp2 _ -> do
2227         setInput inp2
2228         lexToken
2229     AlexToken inp2@(AI end buf2) _ t -> do
2230         setInput inp2
2231         let span = mkRealSrcSpan loc1 end
2232         let bytes = byteDiff buf buf2
2233         span `seq` setLastToken span bytes
2234         t span buf bytes
2235
2236 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
2237 reportLexError loc1 loc2 buf str
2238   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2239   | otherwise =
2240   let c = fst (nextChar buf)
2241   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2242      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2243      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2244
2245 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
2246 lexTokenStream buf loc dflags = unP go initState
2247     where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2248           initState = mkPState dflags' buf loc
2249           go = do
2250             ltok <- lexer return
2251             case ltok of
2252               L _ ITeof -> return []
2253               _ -> liftM (ltok:) go
2254
2255 linePrags = Map.singleton "line" (begin line_prag2)
2256
2257 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2258                                  ("options_ghc", lex_string_prag IToptions_prag),
2259                                  ("options_haddock", lex_string_prag ITdocOptions),
2260                                  ("language", token ITlanguage_prag),
2261                                  ("include", lex_string_prag ITinclude_prag)])
2262
2263 ignoredPrags = Map.fromList (map ignored pragmas)
2264                where ignored opt = (opt, nested_comment lexToken)
2265                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2266                      options_pragmas = map ("options_" ++) impls
2267                      -- CFILES is a hugs-only thing.
2268                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2269
2270 oneWordPrags = Map.fromList([("rules", rulePrag),
2271                            ("inline", token (ITinline_prag Inline FunLike)),
2272                            ("inlinable", token (ITinline_prag Inlinable FunLike)),
2273                            ("inlineable", token (ITinline_prag Inlinable FunLike)),
2274                                           -- Spelling variant
2275                            ("notinline", token (ITinline_prag NoInline FunLike)),
2276                            ("specialize", token ITspec_prag),
2277                            ("source", token ITsource_prag),
2278                            ("warning", token ITwarning_prag),
2279                            ("deprecated", token ITdeprecated_prag),
2280                            ("scc", token ITscc_prag),
2281                            ("generated", token ITgenerated_prag),
2282                            ("core", token ITcore_prag),
2283                            ("unpack", token ITunpack_prag),
2284                            ("nounpack", token ITnounpack_prag),
2285                            ("ann", token ITann_prag),
2286                            ("vectorize", token ITvect_prag),
2287                            ("novectorize", token ITnovect_prag)])
2288
2289 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
2290                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),
2291                              ("specialize inline", token (ITspec_inline_prag True)),
2292                              ("specialize notinline", token (ITspec_inline_prag False)),
2293                              ("vectorize scalar", token ITvect_scalar_prag)])
2294
2295 dispatch_pragmas :: Map String Action -> Action
2296 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
2297                                        Just found -> found span buf len
2298                                        Nothing -> lexError "unknown pragma"
2299
2300 known_pragma :: Map String Action -> AlexAccPred Int
2301 known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
2302                                           && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_')))
2303
2304 clean_pragma :: String -> String
2305 clean_pragma prag = canon_ws (map toLower (unprefix prag))
2306                     where unprefix prag' = case stripPrefix "{-#" prag' of
2307                                              Just rest -> rest
2308                                              Nothing -> prag'
2309                           canonical prag' = case prag' of
2310                                               "noinline" -> "notinline"
2311                                               "specialise" -> "specialize"
2312                                               "vectorise" -> "vectorize"
2313                                               "novectorise" -> "novectorize"
2314                                               "constructorlike" -> "conlike"
2315                                               _ -> prag'
2316                           canon_ws s = unwords (map canonical (words s))
2317 }