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