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