1 -----------------------------------------------------------------------------
2 -- (c) The University of Glasgow, 2006
6 -- This is a combination of an Alex-generated lexer from a regex
7 -- definition, with some hand-coded bits.
9 -- Completely accurate information about token-spans within the source
10 -- file is maintained. Every token has a start and end SrcLoc attached to it.
12 -----------------------------------------------------------------------------
16 -- - parsing integers is a bit slow
17 -- - readRational is a bit slow
19 -- Known bugs, that were also in the previous version:
20 -- - M... should be 3 tokens, not 1.
21 -- - pragma-end should be only valid in a pragma
25 -- The above warning supression flag is a temporary kludge.
26 -- While working on this module you are encouraged to remove it and fix
27 -- any warnings in the module. See
28 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
31 -- Note that Alex itself generates code with with some unused bindings and
32 -- without type signatures, so removing the flag might not be possible.
35 Token(..), lexer, pragState, mkPState, PState(..),
36 P(..), ParseResult(..), getSrcLoc,
37 failLocMsgP, failSpanMsgP, srcParseFail,
39 popContext, pushCurrentContext, setLastToken, setSrcLoc,
40 getLexState, popLexState, pushLexState,
41 extension, standaloneDerivingEnabled, bangPatEnabled,
55 import Util ( maybePrefixMatch, readRational )
59 import Data.Char ( chr, ord, isSpace )
63 #if __GLASGOW_HASKELL__ >= 605
64 import Data.Char ( GeneralCategory(..), generalCategory, isPrint, isUpper )
66 import Compat.Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
70 $unispace = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
71 $whitechar = [\ \n\r\f\v\xa0 $unispace]
72 $white_no_nl = $whitechar # \n
76 $unidigit = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
77 $decdigit = $ascdigit -- for now, should really be $digit (ToDo)
78 $digit = [$ascdigit $unidigit]
80 $special = [\(\)\,\;\[\]\`\{\}]
81 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~ \xa1-\xbf \xd7 \xf7]
82 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
83 $symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
85 $unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
86 $asclarge = [A-Z \xc0-\xd6 \xd8-\xde]
87 $large = [$asclarge $unilarge]
89 $unismall = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
90 $ascsmall = [a-z \xdf-\xf6 \xf8-\xff]
91 $small = [$ascsmall $unismall \_]
93 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
94 $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\']
97 $hexit = [$decdigit A-F a-f]
98 $symchar = [$symbol \:]
100 $idchar = [$small $large $digit \']
102 $docsym = [\| \^ \* \$]
104 @varid = $small $idchar*
105 @conid = $large $idchar*
107 @varsym = $symbol $symchar*
108 @consym = \: $symchar*
110 @decimal = $decdigit+
112 @hexadecimal = $hexit+
113 @exponent = [eE] [\-\+]? @decimal
115 -- we support the hierarchical module name extension:
118 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
120 -- normal signed numerical literals can only be explicitly negative,
121 -- not explicitly positive (contrast @exponent)
123 @signed = @negative ?
127 -- everywhere: skip whitespace and comments
129 $tab+ { warn Opt_WarnTabs (text "Tab character") }
131 -- Everywhere: deal with nested comments. We explicitly rule out
132 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
133 -- (this can happen even though pragmas will normally take precedence due to
134 -- longest-match, because pragmas aren't valid in every state, but comments
135 -- are). We also rule out nested Haddock comments, if the -haddock flag is
138 "{-" / { isNormalComment } { nested_comment lexToken }
140 -- Single-line comments are a bit tricky. Haskell 98 says that two or
141 -- more dashes followed by a symbol should be parsed as a varsym, so we
142 -- have to exclude those.
144 -- Since Haddock comments aren't valid in every state, we need to rule them
147 -- The following two rules match comments that begin with two dashes, but
148 -- continue with a different character. The rules test that this character
149 -- is not a symbol (in which case we'd have a varsym), and that it's not a
150 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
151 -- have a Haddock comment). The rules then munch the rest of the line.
153 "-- " ~[$docsym \#] .* ;
154 "--" [^$symbol : \ ] .* ;
156 -- Next, match Haddock comments if no -haddock flag
158 "-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } ;
160 -- Now, when we've matched comments that begin with 2 dashes and continue
161 -- with a different character, we need to match comments that begin with three
162 -- or more dashes (which clearly can't be Haddock comments). We only need to
163 -- make sure that the first non-dash character isn't a symbol, and munch the
166 "---"\-* [^$symbol :] .* ;
168 -- Since the previous rules all match dashes followed by at least one
169 -- character, we also need to match a whole line filled with just dashes.
171 "--"\-* / { atEOL } ;
173 -- We need this rule since none of the other single line comment rules
174 -- actually match this case.
178 -- 'bol' state: beginning of a line. Slurp up all the whitespace (including
179 -- blank lines) until we find a non-whitespace character, then do layout
182 -- One slight wibble here: what if the line begins with {-#? In
183 -- theory, we have to lex the pragma to see if it's one we recognise,
184 -- and if it is, then we backtrack and do_bol, otherwise we treat it
185 -- as a nested comment. We don't bother with this: if the line begins
186 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
189 ^\# (line)? { begin line_prag1 }
190 ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently
191 ^\# \! .* \n ; -- #!, for scripts
195 -- after a layout keyword (let, where, do, of), we begin a new layout
196 -- context if the curly brace is missing.
197 -- Careful! This stuff is quite delicate.
198 <layout, layout_do> {
199 \{ / { notFollowedBy '-' } { pop_and open_brace }
200 -- we might encounter {-# here, but {- has been handled already
202 ^\# (line)? { begin line_prag1 }
205 -- do is treated in a subtly different way, see new_layout_context
206 <layout> () { new_layout_context True }
207 <layout_do> () { new_layout_context False }
209 -- after a new layout context which was found to be to the left of the
210 -- previous context, we have generated a '{' token, and we now need to
211 -- generate a matching '}' token.
212 <layout_left> () { do_layout_left }
214 <0,option_prags> \n { begin bol }
216 "{-#" $whitechar* (line|LINE) { begin line_prag2 }
218 -- single-line line pragmas, of the form
219 -- # <line> "<file>" <extra-stuff> \n
220 <line_prag1> $decdigit+ { setLine line_prag1a }
221 <line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b }
222 <line_prag1b> .* { pop }
224 -- Haskell-style line pragmas, of the form
225 -- {-# LINE <line> "<file>" #-}
226 <line_prag2> $decdigit+ { setLine line_prag2a }
227 <line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b }
228 <line_prag2b> "#-}"|"-}" { pop }
229 -- NOTE: accept -} at the end of a LINE pragma, for compatibility
230 -- with older versions of GHC which generated these.
232 -- We only want RULES pragmas to be picked up when explicit forall
233 -- syntax is enabled is on, because the contents of the pragma always
234 -- uses it. If it's not on then we're sure to get a parse error.
235 -- (ToDo: we should really emit a warning when ignoring pragmas)
236 -- XXX Now that we can enable this without the -fglasgow-exts hammer,
237 -- is it better just to let the parse error happen?
239 "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
242 "{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) }
243 "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
244 { token (ITinline_prag False) }
245 "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
246 { token ITspec_prag }
247 "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
248 $whitechar* (INLINE|inline) { token (ITspec_inline_prag True) }
249 "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
250 $whitechar* (NO(T?)INLINE|no(t?)inline)
251 { token (ITspec_inline_prag False) }
252 "{-#" $whitechar* (SOURCE|source) { token ITsource_prag }
253 "{-#" $whitechar* (DEPRECATED|deprecated)
254 { token ITdeprecated_prag }
255 "{-#" $whitechar* (SCC|scc) { token ITscc_prag }
256 "{-#" $whitechar* (GENERATED|generated)
257 { token ITgenerated_prag }
258 "{-#" $whitechar* (CORE|core) { token ITcore_prag }
259 "{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
261 "{-#" { nested_comment lexToken }
263 -- ToDo: should only be valid inside a pragma:
264 "#-}" { token ITclose_prag}
268 "{-#" $whitechar* (OPTIONS|options) { lex_string_prag IToptions_prag }
269 "{-#" $whitechar* (OPTIONS_GHC|options_ghc)
270 { lex_string_prag IToptions_prag }
271 "{-#" $whitechar* (OPTIONS_HADDOCK|options_haddock)
272 { lex_string_prag ITdocOptions }
273 "-- #" { multiline_doc_comment }
274 "{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
275 "{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
283 -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
284 "{-#" $whitechar* $idchar+ { nested_comment lexToken }
287 -- '0' state: ordinary lexemes
292 "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
293 "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
299 "[:" / { ifExtension parrEnabled } { token ITopabrack }
300 ":]" / { ifExtension parrEnabled } { token ITcpabrack }
304 "[|" / { ifExtension thEnabled } { token ITopenExpQuote }
305 "[e|" / { ifExtension thEnabled } { token ITopenExpQuote }
306 "[p|" / { ifExtension thEnabled } { token ITopenPatQuote }
307 "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote }
308 "[t|" / { ifExtension thEnabled } { token ITopenTypQuote }
309 "|]" / { ifExtension thEnabled } { token ITcloseQuote }
310 \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
311 "$(" / { ifExtension thEnabled } { token ITparenEscape }
313 "[$" @varid "|" / { ifExtension qqEnabled }
314 { lex_quasiquote_tok }
318 "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
319 { special IToparenbar }
320 "|)" / { ifExtension arrowsEnabled } { special ITcparenbar }
324 \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
328 "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
329 { token IToubxparen }
330 "#)" / { ifExtension unboxedTuplesEnabled }
331 { token ITcubxparen }
335 "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
336 "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
340 \( { special IToparen }
341 \) { special ITcparen }
342 \[ { special ITobrack }
343 \] { special ITcbrack }
344 \, { special ITcomma }
345 \; { special ITsemi }
346 \` { special ITbackquote }
353 @qual @varid { idtoken qvarid }
354 @qual @conid { idtoken qconid }
356 @conid { idtoken conid }
360 @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
361 @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
362 @varid "#"+ / { ifExtension magicHashEnabled } { varid }
363 @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
369 @qual @varsym { idtoken qvarsym }
370 @qual @consym { idtoken qconsym }
375 -- For the normal boxed literals we need to be careful
376 -- when trying to be close to Haskell98
378 -- Normal integral literals (:: Num a => a, from Integer)
379 @decimal { tok_num positive 0 0 decimal }
380 0[oO] @octal { tok_num positive 2 2 octal }
381 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
383 -- Normal rational literals (:: Fractional a => a, from Rational)
384 @floating_point { strtoken tok_float }
388 -- Unboxed ints (:: Int#) and words (:: Word#)
389 -- It's simpler (and faster?) to give separate cases to the negatives,
390 -- especially considering octal/hexadecimal prefixes.
391 @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
392 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
393 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
394 @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
395 @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
396 @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
398 @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
399 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
400 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
402 -- Unboxed floats and doubles (:: Float#, :: Double#)
403 -- prim_{float,double} work with signed literals
404 @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
405 @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
408 -- Strings and chars are lexed by hand-written code. The reason is
409 -- that even if we recognise the string or char here in the regex
410 -- lexer, we would still have to parse the string afterward in order
411 -- to convert it to a String.
414 \" { lex_string_tok }
418 -- -----------------------------------------------------------------------------
422 = ITas -- Haskell keywords
446 | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now)
448 | ITforall -- GHC extension keywords
466 | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
467 | ITspec_prag -- SPECIALISE
468 | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE)
475 | ITcore_prag -- hdaume: core annotations
478 | IToptions_prag String
479 | ITinclude_prag String
482 | ITdotdot -- reserved symbols
498 | ITbiglam -- GHC-extension symbols
500 | ITocurly -- special symbols
502 | ITocurlybar -- {|, for type applications
503 | ITccurlybar -- |}, for type applications
507 | ITopabrack -- [:, for parallel arrays with -XParr
508 | ITcpabrack -- :], for parallel arrays with -XParr
519 | ITvarid FastString -- identifiers
521 | ITvarsym FastString
522 | ITconsym FastString
523 | ITqvarid (FastString,FastString)
524 | ITqconid (FastString,FastString)
525 | ITqvarsym (FastString,FastString)
526 | ITqconsym (FastString,FastString)
528 | ITdupipvarid FastString -- GHC extension: implicit param: ?x
530 | ITpragma StringBuffer
533 | ITstring FastString
535 | ITrational Rational
538 | ITprimstring FastString
541 | ITprimfloat Rational
542 | ITprimdouble Rational
544 -- MetaHaskell extension tokens
545 | ITopenExpQuote -- [| or [e|
546 | ITopenPatQuote -- [p|
547 | ITopenDecQuote -- [d|
548 | ITopenTypQuote -- [t|
550 | ITidEscape FastString -- $x
551 | ITparenEscape -- $(
554 | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
556 -- Arrow notation extension
563 | ITLarrowtail -- -<<
564 | ITRarrowtail -- >>-
566 | ITunknown String -- Used when the lexer can't make sense of it
567 | ITeof -- end of file token
569 -- Documentation annotations
570 | ITdocCommentNext String -- something beginning '-- |'
571 | ITdocCommentPrev String -- something beginning '-- ^'
572 | ITdocCommentNamed String -- something beginning '-- $'
573 | ITdocSection Int String -- a section heading
574 | ITdocOptions String -- doc options (prune, ignore-exports, etc)
575 | ITdocOptionsOld String -- doc options declared "-- # ..."-style
578 deriving Show -- debugging
582 isSpecial :: Token -> Bool
583 -- If we see M.x, where x is a keyword, but
584 -- is special, we treat is as just plain M.x,
586 isSpecial ITas = True
587 isSpecial IThiding = True
588 isSpecial ITqualified = True
589 isSpecial ITforall = True
590 isSpecial ITexport = True
591 isSpecial ITlabel = True
592 isSpecial ITdynamic = True
593 isSpecial ITsafe = True
594 isSpecial ITthreadsafe = True
595 isSpecial ITunsafe = True
596 isSpecial ITccallconv = True
597 isSpecial ITstdcallconv = True
598 isSpecial ITmdo = True
599 isSpecial ITfamily = True
600 isSpecial ITgroup = True
601 isSpecial ITby = True
602 isSpecial ITusing = True
606 -- the bitmap provided as the third component indicates whether the
607 -- corresponding extension keyword is valid under the extension options
608 -- provided to the compiler; if the extension corresponding to *any* of the
609 -- bits set in the bitmap is enabled, the keyword is valid (this setup
610 -- facilitates using a keyword in two different extensions that can be
611 -- activated independently)
613 reservedWordsFM = listToUFM $
614 map (\(x, y, z) -> (mkFastString x, (y, z)))
615 [( "_", ITunderscore, 0 ),
617 ( "case", ITcase, 0 ),
618 ( "class", ITclass, 0 ),
619 ( "data", ITdata, 0 ),
620 ( "default", ITdefault, 0 ),
621 ( "deriving", ITderiving, 0 ),
623 ( "else", ITelse, 0 ),
624 ( "hiding", IThiding, 0 ),
626 ( "import", ITimport, 0 ),
628 ( "infix", ITinfix, 0 ),
629 ( "infixl", ITinfixl, 0 ),
630 ( "infixr", ITinfixr, 0 ),
631 ( "instance", ITinstance, 0 ),
633 ( "module", ITmodule, 0 ),
634 ( "newtype", ITnewtype, 0 ),
636 ( "qualified", ITqualified, 0 ),
637 ( "then", ITthen, 0 ),
638 ( "type", ITtype, 0 ),
639 ( "where", ITwhere, 0 ),
640 ( "_scc_", ITscc, 0 ), -- ToDo: remove
642 ( "forall", ITforall, bit explicitForallBit),
643 ( "mdo", ITmdo, bit recursiveDoBit),
644 ( "family", ITfamily, bit tyFamBit),
645 ( "group", ITgroup, bit transformComprehensionsBit),
646 ( "by", ITby, bit transformComprehensionsBit),
647 ( "using", ITusing, bit transformComprehensionsBit),
649 ( "foreign", ITforeign, bit ffiBit),
650 ( "export", ITexport, bit ffiBit),
651 ( "label", ITlabel, bit ffiBit),
652 ( "dynamic", ITdynamic, bit ffiBit),
653 ( "safe", ITsafe, bit ffiBit),
654 ( "threadsafe", ITthreadsafe, bit ffiBit),
655 ( "unsafe", ITunsafe, bit ffiBit),
656 ( "stdcall", ITstdcallconv, bit ffiBit),
657 ( "ccall", ITccallconv, bit ffiBit),
658 ( "dotnet", ITdotnet, bit ffiBit),
660 ( "rec", ITrec, bit arrowsBit),
661 ( "proc", ITproc, bit arrowsBit)
664 reservedSymsFM :: UniqFM (Token, Int -> Bool)
665 reservedSymsFM = listToUFM $
666 map (\ (x,y,z) -> (mkFastString x,(y,z)))
667 [ ("..", ITdotdot, always)
668 -- (:) is a reserved op, meaning only list cons
669 ,(":", ITcolon, always)
670 ,("::", ITdcolon, always)
671 ,("=", ITequal, always)
672 ,("\\", ITlam, always)
673 ,("|", ITvbar, always)
674 ,("<-", ITlarrow, always)
675 ,("->", ITrarrow, always)
677 ,("~", ITtilde, always)
678 ,("=>", ITdarrow, always)
679 ,("-", ITminus, always)
680 ,("!", ITbang, always)
682 -- For data T (a::*) = MkT
683 ,("*", ITstar, \i -> kindSigsEnabled i || tyFamEnabled i)
684 -- For 'forall a . t'
685 ,(".", ITdot, explicitForallEnabled)
687 ,("-<", ITlarrowtail, arrowsEnabled)
688 ,(">-", ITrarrowtail, arrowsEnabled)
689 ,("-<<", ITLarrowtail, arrowsEnabled)
690 ,(">>-", ITRarrowtail, arrowsEnabled)
692 #if __GLASGOW_HASKELL__ >= 605
693 ,("∷", ITdcolon, unicodeSyntaxEnabled)
694 ,("⇒", ITdarrow, unicodeSyntaxEnabled)
695 ,("∀", ITforall, \i -> unicodeSyntaxEnabled i &&
696 explicitForallEnabled i)
697 ,("→", ITrarrow, unicodeSyntaxEnabled)
698 ,("←", ITlarrow, unicodeSyntaxEnabled)
699 ,("⋯", ITdotdot, unicodeSyntaxEnabled)
700 -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
701 -- form part of a large operator. This would let us have a better
702 -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
706 -- -----------------------------------------------------------------------------
709 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
711 special :: Token -> Action
712 special tok span _buf _len = return (L span tok)
714 token, layout_token :: Token -> Action
715 token t span _buf _len = return (L span t)
716 layout_token t span _buf _len = pushLexState layout >> return (L span t)
718 idtoken :: (StringBuffer -> Int -> Token) -> Action
719 idtoken f span buf len = return (L span $! (f buf len))
721 skip_one_varid :: (FastString -> Token) -> Action
722 skip_one_varid f span buf len
723 = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
725 strtoken :: (String -> Token) -> Action
726 strtoken f span buf len =
727 return (L span $! (f $! lexemeToString buf len))
729 init_strtoken :: Int -> (String -> Token) -> Action
730 -- like strtoken, but drops the last N character(s)
731 init_strtoken drop f span buf len =
732 return (L span $! (f $! lexemeToString buf (len-drop)))
734 begin :: Int -> Action
735 begin code _span _str _len = do pushLexState code; lexToken
738 pop _span _buf _len = do popLexState; lexToken
740 pop_and :: Action -> Action
741 pop_and act span buf len = do popLexState; act span buf len
743 {-# INLINE nextCharIs #-}
744 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
746 notFollowedBy char _ _ _ (AI _ _ buf)
747 = nextCharIs buf (/=char)
749 notFollowedBySymbol _ _ _ (AI _ _ buf)
750 = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
752 -- We must reject doc comments as being ordinary comments everywhere.
753 -- In some cases the doc comment will be selected as the lexeme due to
754 -- maximal munch, but not always, because the nested comment rule is
755 -- valid in all states, but the doc-comment rules are only valid in
756 -- the non-layout states.
757 isNormalComment bits _ _ (AI _ _ buf)
758 | haddockEnabled bits = notFollowedByDocOrPragma
759 | otherwise = nextCharIs buf (/='#')
761 notFollowedByDocOrPragma
762 = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
764 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
767 haddockDisabledAnd p bits _ _ (AI _ _ buf)
768 = if haddockEnabled bits then False else (p buf)
771 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
773 ifExtension pred bits _ _ _ = pred bits
775 multiline_doc_comment :: Action
776 multiline_doc_comment span buf _len = withLexedDocType (worker "")
778 worker commentAcc input docType oneLine = case alexGetChar input of
780 | oneLine -> docCommentEnd input commentAcc docType buf span
781 | otherwise -> case checkIfCommentLine input' of
782 Just input -> worker ('\n':commentAcc) input docType False
783 Nothing -> docCommentEnd input commentAcc docType buf span
784 Just (c, input) -> worker (c:commentAcc) input docType oneLine
785 Nothing -> docCommentEnd input commentAcc docType buf span
787 checkIfCommentLine input = check (dropNonNewlineSpace input)
789 check input = case alexGetChar input of
790 Just ('-', input) -> case alexGetChar input of
791 Just ('-', input) -> case alexGetChar input of
792 Just (c, _) | c /= '-' -> Just input
797 dropNonNewlineSpace input = case alexGetChar input of
799 | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
804 nested comments require traversing by hand, they can't be parsed
805 using regular expressions.
807 nested_comment :: P (Located Token) -> Action
808 nested_comment cont span _str _len = do
812 go 0 input = do setInput input; cont
813 go n input = case alexGetChar input of
814 Nothing -> errBrace input span
815 Just ('-',input) -> case alexGetChar input of
816 Nothing -> errBrace input span
817 Just ('\125',input) -> go (n-1) input
818 Just (_,_) -> go n input
819 Just ('\123',input) -> case alexGetChar input of
820 Nothing -> errBrace input span
821 Just ('-',input) -> go (n+1) input
822 Just (_,_) -> go n input
823 Just (_,input) -> go n input
825 nested_doc_comment :: Action
826 nested_doc_comment span buf _len = withLexedDocType (go "")
828 go commentAcc input docType _ = case alexGetChar input of
829 Nothing -> errBrace input span
830 Just ('-',input) -> case alexGetChar input of
831 Nothing -> errBrace input span
832 Just ('\125',input) ->
833 docCommentEnd input commentAcc docType buf span
834 Just (_,_) -> go ('-':commentAcc) input docType False
835 Just ('\123', input) -> case alexGetChar input of
836 Nothing -> errBrace input span
837 Just ('-',input) -> do
839 let cont = do input <- getInput; go commentAcc input docType False
840 nested_comment cont span buf _len
841 Just (_,_) -> go ('\123':commentAcc) input docType False
842 Just (c,input) -> go (c:commentAcc) input docType False
844 withLexedDocType lexDocComment = do
845 input@(AI _ _ buf) <- getInput
846 case prevChar buf ' ' of
847 '|' -> lexDocComment input ITdocCommentNext False
848 '^' -> lexDocComment input ITdocCommentPrev False
849 '$' -> lexDocComment input ITdocCommentNamed False
850 '*' -> lexDocSection 1 input
851 '#' -> lexDocComment input ITdocOptionsOld False
853 lexDocSection n input = case alexGetChar input of
854 Just ('*', input) -> lexDocSection (n+1) input
855 Just (_, _) -> lexDocComment input (ITdocSection n) True
856 Nothing -> do setInput input; lexToken -- eof reached, lex it normally
859 -------------------------------------------------------------------------------
860 -- This function is quite tricky. We can't just return a new token, we also
861 -- need to update the state of the parser. Why? Because the token is longer
862 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
863 -- it writes the wrong token length to the parser state. This function is
864 -- called afterwards, so it can just update the state.
866 -- This is complicated by the fact that Haddock tokens can span multiple lines,
867 -- which is something that the original lexer didn't account for.
868 -- I have added last_line_len in the parser state which represents the length
869 -- of the part of the token that is on the last line. It is now used for layout
870 -- calculation in pushCurrentContext instead of last_len. last_len is, like it
871 -- was before, the full length of the token, and it is now only used for error
874 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
875 SrcSpan -> P (Located Token)
876 docCommentEnd input commentAcc docType buf span = do
878 let (AI loc last_offs nextBuf) = input
879 comment = reverse commentAcc
880 span' = mkSrcSpan (srcSpanStart span) loc
881 last_len = byteDiff buf nextBuf
883 last_line_len = if (last_offs - last_len < 0)
887 span `seq` setLastToken span' last_len last_line_len
888 return (L span' (docType comment))
890 errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
892 open_brace, close_brace :: Action
893 open_brace span _str _len = do
895 setContext (NoLayout:ctx)
896 return (L span ITocurly)
897 close_brace span _str _len = do
899 return (L span ITccurly)
901 qvarid buf len = ITqvarid $! splitQualName buf len
902 qconid buf len = ITqconid $! splitQualName buf len
904 splitQualName :: StringBuffer -> Int -> (FastString,FastString)
905 -- takes a StringBuffer and a length, and returns the module name
906 -- and identifier parts of a qualified name. Splits at the *last* dot,
907 -- because of hierarchical module names.
908 splitQualName orig_buf len = split orig_buf orig_buf
911 | orig_buf `byteDiff` buf >= len = done dot_buf
912 | c == '.' = found_dot buf'
913 | otherwise = split buf' dot_buf
915 (c,buf') = nextChar buf
917 -- careful, we might get names like M....
918 -- so, if the character after the dot is not upper-case, this is
919 -- the end of the qualifier part.
920 found_dot buf -- buf points after the '.'
921 | isUpper c = split buf' buf
922 | otherwise = done buf
924 (c,buf') = nextChar buf
927 (lexemeToFastString orig_buf (qual_size - 1),
928 lexemeToFastString dot_buf (len - qual_size))
930 qual_size = orig_buf `byteDiff` dot_buf
934 case lookupUFM reservedWordsFM fs of
935 Just (keyword,0) -> do
937 return (L span keyword)
938 Just (keyword,exts) -> do
939 b <- extension (\i -> exts .&. i /= 0)
940 if b then do maybe_layout keyword
941 return (L span keyword)
942 else return (L span (ITvarid fs))
943 _other -> return (L span (ITvarid fs))
945 fs = lexemeToFastString buf len
947 conid buf len = ITconid fs
948 where fs = lexemeToFastString buf len
950 qvarsym buf len = ITqvarsym $! splitQualName buf len
951 qconsym buf len = ITqconsym $! splitQualName buf len
953 varsym = sym ITvarsym
954 consym = sym ITconsym
956 sym con span buf len =
957 case lookupUFM reservedSymsFM fs of
958 Just (keyword,exts) -> do
960 if b then return (L span keyword)
961 else return (L span $! con fs)
962 _other -> return (L span $! con fs)
964 fs = lexemeToFastString buf len
966 -- Variations on the integral numeric literal.
967 tok_integral :: (Integer -> Token)
968 -> (Integer -> Integer)
969 -- -> (StringBuffer -> StringBuffer) -> (Int -> Int)
971 -> (Integer, (Char->Int)) -> Action
972 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
973 return $ L span $ itint $! transint $ parseUnsignedInteger
974 (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
976 -- some conveniences for use with tok_integral
977 tok_num = tok_integral ITinteger
978 tok_primint = tok_integral ITprimint
979 tok_primword = tok_integral ITprimword positive
982 decimal = (10,octDecDigit)
983 octal = (8,octDecDigit)
984 hexadecimal = (16,hexDigit)
986 -- readRational can understand negative rationals, exponents, everything.
987 tok_float str = ITrational $! readRational str
988 tok_primfloat str = ITprimfloat $! readRational str
989 tok_primdouble str = ITprimdouble $! readRational str
991 -- -----------------------------------------------------------------------------
994 -- we're at the first token on a line, insert layout tokens if necessary
996 do_bol span _str _len = do
1000 --trace "layout: inserting '}'" $ do
1002 -- do NOT pop the lex state, we might have a ';' to insert
1003 return (L span ITvccurly)
1005 --trace "layout: inserting ';'" $ do
1007 return (L span ITsemi)
1012 -- certain keywords put us in the "layout" state, where we might
1013 -- add an opening curly brace.
1014 maybe_layout ITdo = pushLexState layout_do
1015 maybe_layout ITmdo = pushLexState layout_do
1016 maybe_layout ITof = pushLexState layout
1017 maybe_layout ITlet = pushLexState layout
1018 maybe_layout ITwhere = pushLexState layout
1019 maybe_layout ITrec = pushLexState layout
1020 maybe_layout _ = return ()
1022 -- Pushing a new implicit layout context. If the indentation of the
1023 -- next token is not greater than the previous layout context, then
1024 -- Haskell 98 says that the new layout context should be empty; that is
1025 -- the lexer must generate {}.
1027 -- We are slightly more lenient than this: when the new context is started
1028 -- by a 'do', then we allow the new context to be at the same indentation as
1029 -- the previous context. This is what the 'strict' argument is for.
1031 new_layout_context strict span _buf _len = do
1033 (AI _ offset _) <- getInput
1036 Layout prev_off : _ |
1037 (strict && prev_off >= offset ||
1038 not strict && prev_off > offset) -> do
1039 -- token is indented to the left of the previous context.
1040 -- we must generate a {} sequence now.
1041 pushLexState layout_left
1042 return (L span ITvocurly)
1044 setContext (Layout offset : ctx)
1045 return (L span ITvocurly)
1047 do_layout_left span _buf _len = do
1049 pushLexState bol -- we must be at the start of a line
1050 return (L span ITvccurly)
1052 -- -----------------------------------------------------------------------------
1055 setLine :: Int -> Action
1056 setLine code span buf len = do
1057 let line = parseUnsignedInteger buf len 10 octDecDigit
1058 setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
1059 -- subtract one: the line number refers to the *following* line
1064 setFile :: Int -> Action
1065 setFile code span buf len = do
1066 let file = lexemeToFastString (stepOn buf) (len-2)
1067 setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1073 -- -----------------------------------------------------------------------------
1074 -- Options, includes and language pragmas.
1076 lex_string_prag :: (String -> Token) -> Action
1077 lex_string_prag mkTok span _buf _len
1078 = do input <- getInput
1082 return (L (mkSrcSpan start end) tok)
1084 = if isString input "#-}"
1085 then do setInput input
1086 return (mkTok (reverse acc))
1087 else case alexGetChar input of
1088 Just (c,i) -> go (c:acc) i
1089 Nothing -> err input
1090 isString _ [] = True
1092 = case alexGetChar i of
1093 Just (c,i') | c == x -> isString i' xs
1095 err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1098 -- -----------------------------------------------------------------------------
1101 -- This stuff is horrible. I hates it.
1103 lex_string_tok :: Action
1104 lex_string_tok span _buf _len = do
1105 tok <- lex_string ""
1107 return (L (mkSrcSpan (srcSpanStart span) end) tok)
1109 lex_string :: String -> P Token
1112 case alexGetChar' i of
1113 Nothing -> lit_error
1117 magicHash <- extension magicHashEnabled
1121 case alexGetChar' i of
1125 then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1126 else let s' = mkZFastString (reverse s) in
1127 return (ITprimstring s')
1128 -- mkZFastString is a hack to avoid encoding the
1129 -- string in UTF-8. We just want the exact bytes.
1131 return (ITstring (mkFastString (reverse s)))
1133 return (ITstring (mkFastString (reverse s)))
1136 | Just ('&',i) <- next -> do
1137 setInput i; lex_string s
1138 | Just (c,i) <- next, is_space c -> do
1139 setInput i; lex_stringgap s
1140 where next = alexGetChar' i
1146 lex_stringgap s = do
1149 '\\' -> lex_string s
1150 c | is_space c -> lex_stringgap s
1154 lex_char_tok :: Action
1155 -- Here we are basically parsing character literals, such as 'x' or '\n'
1156 -- but, when Template Haskell is on, we additionally spot
1157 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
1158 -- but WIHTOUT CONSUMING the x or T part (the parser does that).
1159 -- So we have to do two characters of lookahead: when we see 'x we need to
1160 -- see if there's a trailing quote
1161 lex_char_tok span _buf _len = do -- We've seen '
1162 i1 <- getInput -- Look ahead to first character
1163 let loc = srcSpanStart span
1164 case alexGetChar' i1 of
1165 Nothing -> lit_error
1167 Just ('\'', i2@(AI end2 _ _)) -> do -- We've seen ''
1168 th_exts <- extension thEnabled
1171 return (L (mkSrcSpan loc end2) ITtyQuote)
1174 Just ('\\', i2@(AI _end2 _ _)) -> do -- We've seen 'backslash
1176 lit_ch <- lex_escape
1177 mc <- getCharOrFail -- Trailing quote
1178 if mc == '\'' then finish_char_tok loc lit_ch
1179 else do setInput i2; lit_error
1181 Just (c, i2@(AI _end2 _ _))
1182 | not (isAny c) -> lit_error
1185 -- We've seen 'x, where x is a valid character
1186 -- (i.e. not newline etc) but not a quote or backslash
1187 case alexGetChar' i2 of -- Look ahead one more character
1188 Nothing -> lit_error
1189 Just ('\'', i3) -> do -- We've seen 'x'
1191 finish_char_tok loc c
1192 _other -> do -- We've seen 'x not followed by quote
1193 -- If TH is on, just parse the quote only
1194 th_exts <- extension thEnabled
1195 let (AI end _ _) = i1
1196 if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1197 else do setInput i2; lit_error
1199 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1200 finish_char_tok loc ch -- We've already seen the closing quote
1201 -- Just need to check for trailing #
1202 = do magicHash <- extension magicHashEnabled
1203 i@(AI end _ _) <- getInput
1204 if magicHash then do
1205 case alexGetChar' i of
1206 Just ('#',i@(AI end _ _)) -> do
1208 return (L (mkSrcSpan loc end) (ITprimchar ch))
1210 return (L (mkSrcSpan loc end) (ITchar ch))
1212 return (L (mkSrcSpan loc end) (ITchar ch))
1214 lex_char :: Char -> AlexInput -> P Char
1217 '\\' -> do setInput inp; lex_escape
1218 c | isAny c -> do setInput inp; return c
1221 isAny c | c > '\xff' = isPrint c
1222 | otherwise = is_any c
1224 lex_escape :: P Char
1238 '^' -> do c <- getCharOrFail
1239 if c >= '@' && c <= '_'
1240 then return (chr (ord c - ord '@'))
1243 'x' -> readNum is_hexdigit 16 hexDigit
1244 'o' -> readNum is_octdigit 8 octDecDigit
1245 x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1249 case alexGetChar' i of
1250 Nothing -> lit_error
1252 case alexGetChar' i2 of
1253 Nothing -> do setInput i2; lit_error
1255 let str = [c1,c2,c3] in
1256 case [ (c,rest) | (p,c) <- silly_escape_chars,
1257 Just rest <- [maybePrefixMatch p str] ] of
1258 (escape_char,[]):_ -> do
1261 (escape_char,_:_):_ -> do
1266 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1267 readNum is_digit base conv = do
1271 then readNum2 is_digit base conv (conv c)
1272 else do setInput i; lit_error
1274 readNum2 is_digit base conv i = do
1277 where read i input = do
1278 case alexGetChar' input of
1279 Just (c,input') | is_digit c -> do
1280 read (i*base + conv c) input'
1282 if i >= 0 && i <= 0x10FFFF
1283 then do setInput input; return (chr i)
1286 silly_escape_chars = [
1323 -- before calling lit_error, ensure that the current input is pointing to
1324 -- the position of the error in the buffer. This is so that we can report
1325 -- a correct location to the user, but also so we can detect UTF-8 decoding
1326 -- errors if they occur.
1327 lit_error = lexError "lexical error in string/character literal"
1329 getCharOrFail :: P Char
1332 case alexGetChar' i of
1333 Nothing -> lexError "unexpected end-of-file in string/character literal"
1334 Just (c,i) -> do setInput i; return c
1336 -- -----------------------------------------------------------------------------
1339 lex_quasiquote_tok :: Action
1340 lex_quasiquote_tok span buf len = do
1341 let quoter = reverse $ takeWhile (/= '$')
1342 $ reverse $ lexemeToString buf (len - 1)
1343 quoteStart <- getSrcLoc
1344 quote <- lex_quasiquote ""
1346 return (L (mkSrcSpan (srcSpanStart span) end)
1347 (ITquasiQuote (mkFastString quoter,
1348 mkFastString (reverse quote),
1349 mkSrcSpan quoteStart end)))
1351 lex_quasiquote :: String -> P String
1352 lex_quasiquote s = do
1354 case alexGetChar' i of
1355 Nothing -> lit_error
1358 | Just ('|',i) <- next -> do
1359 setInput i; lex_quasiquote ('|' : s)
1360 | Just (']',i) <- next -> do
1361 setInput i; lex_quasiquote (']' : s)
1362 where next = alexGetChar' i
1365 | Just (']',i) <- next -> do
1366 setInput i; return s
1367 where next = alexGetChar' i
1370 setInput i; lex_quasiquote (c : s)
1372 -- -----------------------------------------------------------------------------
1375 warn :: DynFlag -> SDoc -> Action
1376 warn option warning srcspan _buf _len = do
1377 addWarning option srcspan warning
1380 -- -----------------------------------------------------------------------------
1391 SrcSpan -- The start and end of the text span related to
1392 -- the error. Might be used in environments which can
1393 -- show this span, e.g. by highlighting it.
1394 Message -- The error message
1396 data PState = PState {
1397 buffer :: StringBuffer,
1399 messages :: Messages,
1400 last_loc :: SrcSpan, -- pos of previous token
1401 last_offs :: !Int, -- offset of the previous token from the
1402 -- beginning of the current line.
1403 -- \t is equal to 8 spaces.
1404 last_len :: !Int, -- len of previous token
1405 last_line_len :: !Int,
1406 loc :: SrcLoc, -- current loc (end of prev token + 1)
1407 extsBitmap :: !Int, -- bitmap that determines permitted extensions
1408 context :: [LayoutContext],
1411 -- last_loc and last_len are used when generating error messages,
1412 -- and in pushCurrentContext only. Sigh, if only Happy passed the
1413 -- current token to happyError, we could at least get rid of last_len.
1414 -- Getting rid of last_loc would require finding another way to
1415 -- implement pushCurrentContext (which is only called from one place).
1417 newtype P a = P { unP :: PState -> ParseResult a }
1419 instance Monad P where
1425 returnP a = a `seq` (P $ \s -> POk s a)
1427 thenP :: P a -> (a -> P b) -> P b
1428 (P m) `thenP` k = P $ \ s ->
1430 POk s1 a -> (unP (k a)) s1
1431 PFailed span err -> PFailed span err
1433 failP :: String -> P a
1434 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1436 failMsgP :: String -> P a
1437 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1439 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1440 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
1442 failSpanMsgP :: SrcSpan -> SDoc -> P a
1443 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1445 extension :: (Int -> Bool) -> P Bool
1446 extension p = P $ \s -> POk s (p $! extsBitmap s)
1449 getExts = P $ \s -> POk s (extsBitmap s)
1451 setSrcLoc :: SrcLoc -> P ()
1452 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1454 getSrcLoc :: P SrcLoc
1455 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1457 setLastToken :: SrcSpan -> Int -> Int -> P ()
1458 setLastToken loc len line_len = P $ \s -> POk s {
1461 last_line_len=line_len
1464 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
1466 alexInputPrevChar :: AlexInput -> Char
1467 alexInputPrevChar (AI _ _ buf) = prevChar buf '\n'
1469 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1470 alexGetChar (AI loc ofs s)
1472 | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
1473 --trace (show (ord c)) $
1474 Just (adj_c, (AI loc' ofs' s'))
1475 where (c,s') = nextChar s
1476 loc' = advanceSrcLoc loc c
1477 ofs' = advanceOffs c ofs
1485 other_graphic = '\x6'
1488 | c <= '\x06' = non_graphic
1490 -- Alex doesn't handle Unicode, so when Unicode
1491 -- character is encoutered we output these values
1492 -- with the actual character value hidden in the state.
1494 case generalCategory c of
1495 UppercaseLetter -> upper
1496 LowercaseLetter -> lower
1497 TitlecaseLetter -> upper
1498 ModifierLetter -> other_graphic
1499 OtherLetter -> other_graphic
1500 NonSpacingMark -> other_graphic
1501 SpacingCombiningMark -> other_graphic
1502 EnclosingMark -> other_graphic
1503 DecimalNumber -> digit
1504 LetterNumber -> other_graphic
1505 OtherNumber -> other_graphic
1506 ConnectorPunctuation -> other_graphic
1507 DashPunctuation -> other_graphic
1508 OpenPunctuation -> other_graphic
1509 ClosePunctuation -> other_graphic
1510 InitialQuote -> other_graphic
1511 FinalQuote -> other_graphic
1512 OtherPunctuation -> other_graphic
1513 MathSymbol -> symbol
1514 CurrencySymbol -> symbol
1515 ModifierSymbol -> symbol
1516 OtherSymbol -> symbol
1518 _other -> non_graphic
1520 -- This version does not squash unicode characters, it is used when
1522 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1523 alexGetChar' (AI loc ofs s)
1525 | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
1526 --trace (show (ord c)) $
1527 Just (c, (AI loc' ofs' s'))
1528 where (c,s') = nextChar s
1529 loc' = advanceSrcLoc loc c
1530 ofs' = advanceOffs c ofs
1532 advanceOffs :: Char -> Int -> Int
1533 advanceOffs '\n' _ = 0
1534 advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
1535 advanceOffs _ offs = offs + 1
1537 getInput :: P AlexInput
1538 getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b)
1540 setInput :: AlexInput -> P ()
1541 setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } ()
1543 pushLexState :: Int -> P ()
1544 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1546 popLexState :: P Int
1547 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1549 getLexState :: P Int
1550 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1552 -- for reasons of efficiency, flags indicating language extensions (eg,
1553 -- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
1556 genericsBit, ffiBit, parrBit :: Int
1557 genericsBit = 0 -- {| and |}
1563 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1564 bangPatBit = 8 -- Tells the parser to understand bang-patterns
1565 -- (doesn't affect the lexer)
1566 tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs
1567 haddockBit = 10 -- Lex and parse Haddock comments
1568 magicHashBit = 11 -- # in both functions and operators
1569 kindSigsBit = 12 -- Kind signatures on type variables
1570 recursiveDoBit = 13 -- mdo
1571 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1572 unboxedTuplesBit = 15 -- (# and #)
1573 standaloneDerivingBit = 16 -- standalone instance deriving declarations
1574 transformComprehensionsBit = 17
1575 qqBit = 18 -- enable quasiquoting
1577 genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1579 genericsEnabled flags = testBit flags genericsBit
1580 ffiEnabled flags = testBit flags ffiBit
1581 parrEnabled flags = testBit flags parrBit
1582 arrowsEnabled flags = testBit flags arrowsBit
1583 thEnabled flags = testBit flags thBit
1584 ipEnabled flags = testBit flags ipBit
1585 explicitForallEnabled flags = testBit flags explicitForallBit
1586 bangPatEnabled flags = testBit flags bangPatBit
1587 tyFamEnabled flags = testBit flags tyFamBit
1588 haddockEnabled flags = testBit flags haddockBit
1589 magicHashEnabled flags = testBit flags magicHashBit
1590 kindSigsEnabled flags = testBit flags kindSigsBit
1591 recursiveDoEnabled flags = testBit flags recursiveDoBit
1592 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1593 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1594 standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
1595 transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
1596 qqEnabled flags = testBit flags qqBit
1598 -- PState for parsing options pragmas
1600 pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
1601 pragState dynflags buf loc =
1604 messages = emptyMessages,
1606 last_loc = mkSrcSpan loc loc,
1613 lex_state = [bol, option_prags, 0]
1617 -- create a parse state
1619 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
1620 mkPState buf loc flags =
1624 messages = emptyMessages,
1625 last_loc = mkSrcSpan loc loc,
1630 extsBitmap = fromIntegral bitmap,
1632 lex_state = [bol, 0]
1633 -- we begin in the layout state if toplev_layout is set
1636 bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
1637 .|. ffiBit `setBitIf` dopt Opt_ForeignFunctionInterface flags
1638 .|. parrBit `setBitIf` dopt Opt_PArr flags
1639 .|. arrowsBit `setBitIf` dopt Opt_Arrows flags
1640 .|. thBit `setBitIf` dopt Opt_TemplateHaskell flags
1641 .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags
1642 .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
1643 .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
1644 .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
1645 .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
1646 .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
1647 .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
1648 .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
1649 .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
1650 .|. haddockBit `setBitIf` dopt Opt_Haddock flags
1651 .|. magicHashBit `setBitIf` dopt Opt_MagicHash flags
1652 .|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
1653 .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
1654 .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
1655 .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
1656 .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
1657 .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
1659 setBitIf :: Int -> Bool -> Int
1660 b `setBitIf` cond | cond = bit b
1663 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
1664 addWarning option srcspan warning
1665 = P $ \s@PState{messages=(ws,es), dflags=d} ->
1666 let warning' = mkWarnMsg srcspan alwaysQualify warning
1667 ws' = if dopt option d then ws `snocBag` warning' else ws
1668 in POk s{messages=(ws', es)} ()
1670 getMessages :: PState -> Messages
1671 getMessages PState{messages=ms} = ms
1673 getContext :: P [LayoutContext]
1674 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1676 setContext :: [LayoutContext] -> P ()
1677 setContext ctx = P $ \s -> POk s{context=ctx} ()
1680 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1681 last_len = len, last_loc = last_loc }) ->
1683 (_:tl) -> POk s{ context = tl } ()
1684 [] -> PFailed last_loc (srcParseErr buf len)
1686 -- Push a new layout context at the indentation of the last token read.
1687 -- This is only used at the outer level of a module when the 'module'
1688 -- keyword is missing.
1689 pushCurrentContext :: P ()
1690 pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } ->
1691 POk s{context = Layout (offs-len) : ctx} ()
1692 --trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
1694 getOffside :: P Ordering
1695 getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
1696 let ord = case stk of
1697 (Layout n:_) -> compare offs n
1701 -- ---------------------------------------------------------------------------
1702 -- Construct a parse error
1705 :: StringBuffer -- current buffer (placed just after the last token)
1706 -> Int -- length of the previous token
1709 = hcat [ if null token
1710 then ptext (sLit "parse error (possibly incorrect indentation)")
1711 else hcat [ptext (sLit "parse error on input "),
1712 char '`', text token, char '\'']
1714 where token = lexemeToString (offsetBytes (-len) buf) len
1716 -- Report a parse failure, giving the span of the previous token as
1717 -- the location of the error. This is the entry point for errors
1718 -- detected during parsing.
1720 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1721 last_loc = last_loc } ->
1722 PFailed last_loc (srcParseErr buf len)
1724 -- A lexical error is reported at a particular position in the source file,
1725 -- not over a token range.
1726 lexError :: String -> P a
1729 (AI end _ buf) <- getInput
1730 reportLexError loc end buf str
1732 -- -----------------------------------------------------------------------------
1733 -- This is the top-level function: called from the parser each time a
1734 -- new token is to be read from the input.
1736 lexer :: (Located Token -> P a) -> P a
1738 tok@(L _span _tok__) <- lexToken
1739 -- trace ("token: " ++ show tok__) $ do
1742 lexToken :: P (Located Token)
1744 inp@(AI loc1 _ buf) <- getInput
1747 case alexScanUser exts inp sc of
1749 let span = mkSrcSpan loc1 loc1
1750 setLastToken span 0 0
1751 return (L span ITeof)
1752 AlexError (AI loc2 _ buf) ->
1753 reportLexError loc1 loc2 buf "lexical error"
1754 AlexSkip inp2 _ -> do
1757 AlexToken inp2@(AI end _ buf2) _ t -> do
1759 let span = mkSrcSpan loc1 end
1760 let bytes = byteDiff buf buf2
1761 span `seq` setLastToken span bytes bytes
1764 reportLexError loc1 loc2 buf str
1765 | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
1768 c = fst (nextChar buf)
1770 if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
1771 then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
1772 else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)