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