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,
45 #include "HsVersions.h"
57 import Util ( maybePrefixMatch, readRational )
61 import Data.Char ( chr, ord, isSpace )
65 #if __GLASGOW_HASKELL__ >= 605
66 import Data.Char ( GeneralCategory(..), generalCategory, isPrint, isUpper )
68 import Compat.Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
72 $unispace = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
73 $whitechar = [\ \n\r\f\v\xa0 $unispace]
74 $white_no_nl = $whitechar # \n
78 $unidigit = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
79 $decdigit = $ascdigit -- for now, should really be $digit (ToDo)
80 $digit = [$ascdigit $unidigit]
82 $special = [\(\)\,\;\[\]\`\{\}]
83 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~ \xa1-\xbf \xd7 \xf7]
84 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
85 $symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
87 $unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
88 $asclarge = [A-Z \xc0-\xd6 \xd8-\xde]
89 $large = [$asclarge $unilarge]
91 $unismall = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
92 $ascsmall = [a-z \xdf-\xf6 \xf8-\xff]
93 $small = [$ascsmall $unismall \_]
95 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
96 $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\']
99 $hexit = [$decdigit A-F a-f]
100 $symchar = [$symbol \:]
102 $idchar = [$small $large $digit \']
104 $docsym = [\| \^ \* \$]
106 @varid = $small $idchar*
107 @conid = $large $idchar*
109 @varsym = $symbol $symchar*
110 @consym = \: $symchar*
112 @decimal = $decdigit+
114 @hexadecimal = $hexit+
115 @exponent = [eE] [\-\+]? @decimal
117 -- we support the hierarchical module name extension:
120 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
122 -- normal signed numerical literals can only be explicitly negative,
123 -- not explicitly positive (contrast @exponent)
125 @signed = @negative ?
129 -- everywhere: skip whitespace and comments
131 $tab+ { warn Opt_WarnTabs (text "Tab character") }
133 -- Everywhere: deal with nested comments. We explicitly rule out
134 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
135 -- (this can happen even though pragmas will normally take precedence due to
136 -- longest-match, because pragmas aren't valid in every state, but comments
137 -- are). We also rule out nested Haddock comments, if the -haddock flag is
140 "{-" / { isNormalComment } { nested_comment lexToken }
142 -- Single-line comments are a bit tricky. Haskell 98 says that two or
143 -- more dashes followed by a symbol should be parsed as a varsym, so we
144 -- have to exclude those.
146 -- Since Haddock comments aren't valid in every state, we need to rule them
149 -- The following two rules match comments that begin with two dashes, but
150 -- continue with a different character. The rules test that this character
151 -- is not a symbol (in which case we'd have a varsym), and that it's not a
152 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
153 -- have a Haddock comment). The rules then munch the rest of the line.
155 "-- " ~[$docsym \#] .* ;
156 "--" [^$symbol : \ ] .* ;
158 -- Next, match Haddock comments if no -haddock flag
160 "-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } ;
162 -- Now, when we've matched comments that begin with 2 dashes and continue
163 -- with a different character, we need to match comments that begin with three
164 -- or more dashes (which clearly can't be Haddock comments). We only need to
165 -- make sure that the first non-dash character isn't a symbol, and munch the
168 "---"\-* [^$symbol :] .* ;
170 -- Since the previous rules all match dashes followed by at least one
171 -- character, we also need to match a whole line filled with just dashes.
173 "--"\-* / { atEOL } ;
175 -- We need this rule since none of the other single line comment rules
176 -- actually match this case.
180 -- 'bol' state: beginning of a line. Slurp up all the whitespace (including
181 -- blank lines) until we find a non-whitespace character, then do layout
184 -- One slight wibble here: what if the line begins with {-#? In
185 -- theory, we have to lex the pragma to see if it's one we recognise,
186 -- and if it is, then we backtrack and do_bol, otherwise we treat it
187 -- as a nested comment. We don't bother with this: if the line begins
188 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
191 ^\# (line)? { begin line_prag1 }
192 ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently
193 ^\# \! .* \n ; -- #!, for scripts
197 -- after a layout keyword (let, where, do, of), we begin a new layout
198 -- context if the curly brace is missing.
199 -- Careful! This stuff is quite delicate.
200 <layout, layout_do> {
201 \{ / { notFollowedBy '-' } { pop_and open_brace }
202 -- we might encounter {-# here, but {- has been handled already
204 ^\# (line)? { begin line_prag1 }
207 -- do is treated in a subtly different way, see new_layout_context
208 <layout> () { new_layout_context True }
209 <layout_do> () { new_layout_context False }
211 -- after a new layout context which was found to be to the left of the
212 -- previous context, we have generated a '{' token, and we now need to
213 -- generate a matching '}' token.
214 <layout_left> () { do_layout_left }
216 <0,option_prags> \n { begin bol }
218 "{-#" $whitechar* (line|LINE) { begin line_prag2 }
220 -- single-line line pragmas, of the form
221 -- # <line> "<file>" <extra-stuff> \n
222 <line_prag1> $decdigit+ { setLine line_prag1a }
223 <line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b }
224 <line_prag1b> .* { pop }
226 -- Haskell-style line pragmas, of the form
227 -- {-# LINE <line> "<file>" #-}
228 <line_prag2> $decdigit+ { setLine line_prag2a }
229 <line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b }
230 <line_prag2b> "#-}"|"-}" { pop }
231 -- NOTE: accept -} at the end of a LINE pragma, for compatibility
232 -- with older versions of GHC which generated these.
234 -- We only want RULES pragmas to be picked up when explicit forall
235 -- syntax is enabled is on, because the contents of the pragma always
236 -- uses it. If it's not on then we're sure to get a parse error.
237 -- (ToDo: we should really emit a warning when ignoring pragmas)
238 -- XXX Now that we can enable this without the -fglasgow-exts hammer,
239 -- is it better just to let the parse error happen?
241 "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
244 "{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) }
245 "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
246 { token (ITinline_prag False) }
247 "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
248 { token ITspec_prag }
249 "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
250 $whitechar* (INLINE|inline) { token (ITspec_inline_prag True) }
251 "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
252 $whitechar* (NO(T?)INLINE|no(t?)inline)
253 { token (ITspec_inline_prag False) }
254 "{-#" $whitechar* (SOURCE|source) { token ITsource_prag }
255 "{-#" $whitechar* (DEPRECATED|deprecated)
256 { token ITdeprecated_prag }
257 "{-#" $whitechar* (SCC|scc) { token ITscc_prag }
258 "{-#" $whitechar* (GENERATED|generated)
259 { token ITgenerated_prag }
260 "{-#" $whitechar* (CORE|core) { token ITcore_prag }
261 "{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
263 "{-#" { nested_comment lexToken }
265 -- ToDo: should only be valid inside a pragma:
266 "#-}" { token ITclose_prag}
270 "{-#" $whitechar* (OPTIONS|options) { lex_string_prag IToptions_prag }
271 "{-#" $whitechar* (OPTIONS_GHC|options_ghc)
272 { lex_string_prag IToptions_prag }
273 "{-#" $whitechar* (OPTIONS_HADDOCK|options_haddock)
274 { lex_string_prag ITdocOptions }
275 "-- #" { multiline_doc_comment }
276 "{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
277 "{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
285 -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
286 "{-#" $whitechar* $idchar+ { nested_comment lexToken }
289 -- '0' state: ordinary lexemes
294 "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
295 "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
301 "[:" / { ifExtension parrEnabled } { token ITopabrack }
302 ":]" / { ifExtension parrEnabled } { token ITcpabrack }
306 "[|" / { ifExtension thEnabled } { token ITopenExpQuote }
307 "[e|" / { ifExtension thEnabled } { token ITopenExpQuote }
308 "[p|" / { ifExtension thEnabled } { token ITopenPatQuote }
309 "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote }
310 "[t|" / { ifExtension thEnabled } { token ITopenTypQuote }
311 "|]" / { ifExtension thEnabled } { token ITcloseQuote }
312 \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
313 "$(" / { ifExtension thEnabled } { token ITparenEscape }
315 "[$" @varid "|" / { ifExtension qqEnabled }
316 { lex_quasiquote_tok }
320 "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
321 { special IToparenbar }
322 "|)" / { ifExtension arrowsEnabled } { special ITcparenbar }
326 \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
330 "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
331 { token IToubxparen }
332 "#)" / { ifExtension unboxedTuplesEnabled }
333 { token ITcubxparen }
337 "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
338 "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
342 \( { special IToparen }
343 \) { special ITcparen }
344 \[ { special ITobrack }
345 \] { special ITcbrack }
346 \, { special ITcomma }
347 \; { special ITsemi }
348 \` { special ITbackquote }
355 @qual @varid { idtoken qvarid }
356 @qual @conid { idtoken qconid }
358 @conid { idtoken conid }
362 @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
363 @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
364 @varid "#"+ / { ifExtension magicHashEnabled } { varid }
365 @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
371 @qual @varsym { idtoken qvarsym }
372 @qual @consym { idtoken qconsym }
377 -- For the normal boxed literals we need to be careful
378 -- when trying to be close to Haskell98
380 -- Normal integral literals (:: Num a => a, from Integer)
381 @decimal { tok_num positive 0 0 decimal }
382 0[oO] @octal { tok_num positive 2 2 octal }
383 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
385 -- Normal rational literals (:: Fractional a => a, from Rational)
386 @floating_point { strtoken tok_float }
390 -- Unboxed ints (:: Int#)
391 -- It's simpler (and faster?) to give separate cases to the negatives,
392 -- especially considering octal/hexadecimal prefixes.
393 @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
394 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
395 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
396 @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
397 @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
398 @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
400 -- Unboxed floats and doubles (:: Float#, :: Double#)
401 -- prim_{float,double} work with signed literals
402 @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
403 @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
406 -- Strings and chars are lexed by hand-written code. The reason is
407 -- that even if we recognise the string or char here in the regex
408 -- lexer, we would still have to parse the string afterward in order
409 -- to convert it to a String.
412 \" { lex_string_tok }
416 -- -----------------------------------------------------------------------------
420 = ITas -- Haskell keywords
444 | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now)
446 | ITforall -- GHC extension keywords
464 | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
465 | ITspec_prag -- SPECIALISE
466 | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE)
473 | ITcore_prag -- hdaume: core annotations
476 | IToptions_prag String
477 | ITinclude_prag String
480 | ITdotdot -- reserved symbols
496 | ITbiglam -- GHC-extension symbols
498 | ITocurly -- special symbols
500 | ITocurlybar -- {|, for type applications
501 | ITccurlybar -- |}, for type applications
505 | ITopabrack -- [:, for parallel arrays with -fparr
506 | ITcpabrack -- :], for parallel arrays with -fparr
517 | ITvarid FastString -- identifiers
519 | ITvarsym FastString
520 | ITconsym FastString
521 | ITqvarid (FastString,FastString)
522 | ITqconid (FastString,FastString)
523 | ITqvarsym (FastString,FastString)
524 | ITqconsym (FastString,FastString)
526 | ITdupipvarid FastString -- GHC extension: implicit param: ?x
528 | ITpragma StringBuffer
531 | ITstring FastString
533 | ITrational Rational
536 | ITprimstring FastString
538 | ITprimfloat Rational
539 | ITprimdouble Rational
541 -- MetaHaskell extension tokens
542 | ITopenExpQuote -- [| or [e|
543 | ITopenPatQuote -- [p|
544 | ITopenDecQuote -- [d|
545 | ITopenTypQuote -- [t|
547 | ITidEscape FastString -- $x
548 | ITparenEscape -- $(
551 | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
553 -- Arrow notation extension
560 | ITLarrowtail -- -<<
561 | ITRarrowtail -- >>-
563 | ITunknown String -- Used when the lexer can't make sense of it
564 | ITeof -- end of file token
566 -- Documentation annotations
567 | ITdocCommentNext String -- something beginning '-- |'
568 | ITdocCommentPrev String -- something beginning '-- ^'
569 | ITdocCommentNamed String -- something beginning '-- $'
570 | ITdocSection Int String -- a section heading
571 | ITdocOptions String -- doc options (prune, ignore-exports, etc)
572 | ITdocOptionsOld String -- doc options declared "-- # ..."-style
575 deriving Show -- debugging
579 isSpecial :: Token -> Bool
580 -- If we see M.x, where x is a keyword, but
581 -- is special, we treat is as just plain M.x,
583 isSpecial ITas = True
584 isSpecial IThiding = True
585 isSpecial ITqualified = True
586 isSpecial ITforall = True
587 isSpecial ITexport = True
588 isSpecial ITlabel = True
589 isSpecial ITdynamic = True
590 isSpecial ITsafe = True
591 isSpecial ITthreadsafe = True
592 isSpecial ITunsafe = True
593 isSpecial ITccallconv = True
594 isSpecial ITstdcallconv = True
595 isSpecial ITmdo = True
596 isSpecial ITfamily = True
597 isSpecial ITgroup = True
598 isSpecial ITby = True
599 isSpecial ITusing = True
603 -- the bitmap provided as the third component indicates whether the
604 -- corresponding extension keyword is valid under the extension options
605 -- provided to the compiler; if the extension corresponding to *any* of the
606 -- bits set in the bitmap is enabled, the keyword is valid (this setup
607 -- facilitates using a keyword in two different extensions that can be
608 -- activated independently)
610 reservedWordsFM = listToUFM $
611 map (\(x, y, z) -> (mkFastString x, (y, z)))
612 [( "_", ITunderscore, 0 ),
614 ( "case", ITcase, 0 ),
615 ( "class", ITclass, 0 ),
616 ( "data", ITdata, 0 ),
617 ( "default", ITdefault, 0 ),
618 ( "deriving", ITderiving, 0 ),
620 ( "else", ITelse, 0 ),
621 ( "hiding", IThiding, 0 ),
623 ( "import", ITimport, 0 ),
625 ( "infix", ITinfix, 0 ),
626 ( "infixl", ITinfixl, 0 ),
627 ( "infixr", ITinfixr, 0 ),
628 ( "instance", ITinstance, 0 ),
630 ( "module", ITmodule, 0 ),
631 ( "newtype", ITnewtype, 0 ),
633 ( "qualified", ITqualified, 0 ),
634 ( "then", ITthen, 0 ),
635 ( "type", ITtype, 0 ),
636 ( "where", ITwhere, 0 ),
637 ( "_scc_", ITscc, 0 ), -- ToDo: remove
639 ( "forall", ITforall, bit explicitForallBit),
640 ( "mdo", ITmdo, bit recursiveDoBit),
641 ( "family", ITfamily, bit tyFamBit),
642 ( "group", ITgroup, bit transformComprehensionsBit),
643 ( "by", ITby, bit transformComprehensionsBit),
644 ( "using", ITusing, bit transformComprehensionsBit),
646 ( "foreign", ITforeign, bit ffiBit),
647 ( "export", ITexport, bit ffiBit),
648 ( "label", ITlabel, bit ffiBit),
649 ( "dynamic", ITdynamic, bit ffiBit),
650 ( "safe", ITsafe, bit ffiBit),
651 ( "threadsafe", ITthreadsafe, bit ffiBit),
652 ( "unsafe", ITunsafe, bit ffiBit),
653 ( "stdcall", ITstdcallconv, bit ffiBit),
654 ( "ccall", ITccallconv, bit ffiBit),
655 ( "dotnet", ITdotnet, bit ffiBit),
657 ( "rec", ITrec, bit arrowsBit),
658 ( "proc", ITproc, bit arrowsBit)
661 reservedSymsFM :: UniqFM (Token, Int -> Bool)
662 reservedSymsFM = listToUFM $
663 map (\ (x,y,z) -> (mkFastString x,(y,z)))
664 [ ("..", ITdotdot, always)
665 -- (:) is a reserved op, meaning only list cons
666 ,(":", ITcolon, always)
667 ,("::", ITdcolon, always)
668 ,("=", ITequal, always)
669 ,("\\", ITlam, always)
670 ,("|", ITvbar, always)
671 ,("<-", ITlarrow, always)
672 ,("->", ITrarrow, always)
674 ,("~", ITtilde, always)
675 ,("=>", ITdarrow, always)
676 ,("-", ITminus, always)
677 ,("!", ITbang, always)
679 -- For data T (a::*) = MkT
680 ,("*", ITstar, \i -> kindSigsEnabled i || tyFamEnabled i)
681 -- For 'forall a . t'
682 ,(".", ITdot, explicitForallEnabled)
684 ,("-<", ITlarrowtail, arrowsEnabled)
685 ,(">-", ITrarrowtail, arrowsEnabled)
686 ,("-<<", ITLarrowtail, arrowsEnabled)
687 ,(">>-", ITRarrowtail, arrowsEnabled)
689 #if __GLASGOW_HASKELL__ >= 605
690 ,("∷", ITdcolon, unicodeSyntaxEnabled)
691 ,("⇒", ITdarrow, unicodeSyntaxEnabled)
692 ,("∀", ITforall, \i -> unicodeSyntaxEnabled i &&
693 explicitForallEnabled i)
694 ,("→", ITrarrow, unicodeSyntaxEnabled)
695 ,("←", ITlarrow, unicodeSyntaxEnabled)
696 ,("⋯", ITdotdot, unicodeSyntaxEnabled)
697 -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
698 -- form part of a large operator. This would let us have a better
699 -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
703 -- -----------------------------------------------------------------------------
706 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
708 special :: Token -> Action
709 special tok span _buf _len = return (L span tok)
711 token, layout_token :: Token -> Action
712 token t span _buf _len = return (L span t)
713 layout_token t span _buf _len = pushLexState layout >> return (L span t)
715 idtoken :: (StringBuffer -> Int -> Token) -> Action
716 idtoken f span buf len = return (L span $! (f buf len))
718 skip_one_varid :: (FastString -> Token) -> Action
719 skip_one_varid f span buf len
720 = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
722 strtoken :: (String -> Token) -> Action
723 strtoken f span buf len =
724 return (L span $! (f $! lexemeToString buf len))
726 init_strtoken :: Int -> (String -> Token) -> Action
727 -- like strtoken, but drops the last N character(s)
728 init_strtoken drop f span buf len =
729 return (L span $! (f $! lexemeToString buf (len-drop)))
731 begin :: Int -> Action
732 begin code _span _str _len = do pushLexState code; lexToken
735 pop _span _buf _len = do popLexState; lexToken
737 pop_and :: Action -> Action
738 pop_and act span buf len = do popLexState; act span buf len
740 {-# INLINE nextCharIs #-}
741 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
743 notFollowedBy char _ _ _ (AI _ _ buf)
744 = nextCharIs buf (/=char)
746 notFollowedBySymbol _ _ _ (AI _ _ buf)
747 = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
749 -- We must reject doc comments as being ordinary comments everywhere.
750 -- In some cases the doc comment will be selected as the lexeme due to
751 -- maximal munch, but not always, because the nested comment rule is
752 -- valid in all states, but the doc-comment rules are only valid in
753 -- the non-layout states.
754 isNormalComment bits _ _ (AI _ _ buf)
755 | haddockEnabled bits = notFollowedByDocOrPragma
756 | otherwise = nextCharIs buf (/='#')
758 notFollowedByDocOrPragma
759 = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
761 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
764 haddockDisabledAnd p bits _ _ (AI _ _ buf)
765 = if haddockEnabled bits then False else (p buf)
768 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
770 ifExtension pred bits _ _ _ = pred bits
772 multiline_doc_comment :: Action
773 multiline_doc_comment span buf _len = withLexedDocType (worker "")
775 worker commentAcc input docType oneLine = case alexGetChar input of
777 | oneLine -> docCommentEnd input commentAcc docType buf span
778 | otherwise -> case checkIfCommentLine input' of
779 Just input -> worker ('\n':commentAcc) input docType False
780 Nothing -> docCommentEnd input commentAcc docType buf span
781 Just (c, input) -> worker (c:commentAcc) input docType oneLine
782 Nothing -> docCommentEnd input commentAcc docType buf span
784 checkIfCommentLine input = check (dropNonNewlineSpace input)
786 check input = case alexGetChar input of
787 Just ('-', input) -> case alexGetChar input of
788 Just ('-', input) -> case alexGetChar input of
789 Just (c, _) | c /= '-' -> Just input
794 dropNonNewlineSpace input = case alexGetChar input of
796 | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
801 nested comments require traversing by hand, they can't be parsed
802 using regular expressions.
804 nested_comment :: P (Located Token) -> Action
805 nested_comment cont span _str _len = do
809 go 0 input = do setInput input; cont
810 go n input = case alexGetChar input of
811 Nothing -> errBrace input span
812 Just ('-',input) -> case alexGetChar input of
813 Nothing -> errBrace input span
814 Just ('\125',input) -> go (n-1) input
815 Just (_,_) -> go n input
816 Just ('\123',input) -> case alexGetChar input of
817 Nothing -> errBrace input span
818 Just ('-',input) -> go (n+1) input
819 Just (_,_) -> go n input
820 Just (_,input) -> go n input
822 nested_doc_comment :: Action
823 nested_doc_comment span buf _len = withLexedDocType (go "")
825 go commentAcc input docType _ = case alexGetChar input of
826 Nothing -> errBrace input span
827 Just ('-',input) -> case alexGetChar input of
828 Nothing -> errBrace input span
829 Just ('\125',input) ->
830 docCommentEnd input commentAcc docType buf span
831 Just (_,_) -> go ('-':commentAcc) input docType False
832 Just ('\123', input) -> case alexGetChar input of
833 Nothing -> errBrace input span
834 Just ('-',input) -> do
836 let cont = do input <- getInput; go commentAcc input docType False
837 nested_comment cont span buf _len
838 Just (_,_) -> go ('\123':commentAcc) input docType False
839 Just (c,input) -> go (c:commentAcc) input docType False
841 withLexedDocType lexDocComment = do
842 input@(AI _ _ buf) <- getInput
843 case prevChar buf ' ' of
844 '|' -> lexDocComment input ITdocCommentNext False
845 '^' -> lexDocComment input ITdocCommentPrev False
846 '$' -> lexDocComment input ITdocCommentNamed False
847 '*' -> lexDocSection 1 input
848 '#' -> lexDocComment input ITdocOptionsOld False
850 lexDocSection n input = case alexGetChar input of
851 Just ('*', input) -> lexDocSection (n+1) input
852 Just (_, _) -> lexDocComment input (ITdocSection n) True
853 Nothing -> do setInput input; lexToken -- eof reached, lex it normally
856 -------------------------------------------------------------------------------
857 -- This function is quite tricky. We can't just return a new token, we also
858 -- need to update the state of the parser. Why? Because the token is longer
859 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
860 -- it writes the wrong token length to the parser state. This function is
861 -- called afterwards, so it can just update the state.
863 -- This is complicated by the fact that Haddock tokens can span multiple lines,
864 -- which is something that the original lexer didn't account for.
865 -- I have added last_line_len in the parser state which represents the length
866 -- of the part of the token that is on the last line. It is now used for layout
867 -- calculation in pushCurrentContext instead of last_len. last_len is, like it
868 -- was before, the full length of the token, and it is now only used for error
871 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
872 SrcSpan -> P (Located Token)
873 docCommentEnd input commentAcc docType buf span = do
875 let (AI loc last_offs nextBuf) = input
876 comment = reverse commentAcc
877 span' = mkSrcSpan (srcSpanStart span) loc
878 last_len = byteDiff buf nextBuf
880 last_line_len = if (last_offs - last_len < 0)
884 span `seq` setLastToken span' last_len last_line_len
885 return (L span' (docType comment))
887 errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
889 open_brace, close_brace :: Action
890 open_brace span _str _len = do
892 setContext (NoLayout:ctx)
893 return (L span ITocurly)
894 close_brace span _str _len = do
896 return (L span ITccurly)
898 qvarid buf len = ITqvarid $! splitQualName buf len
899 qconid buf len = ITqconid $! splitQualName buf len
901 splitQualName :: StringBuffer -> Int -> (FastString,FastString)
902 -- takes a StringBuffer and a length, and returns the module name
903 -- and identifier parts of a qualified name. Splits at the *last* dot,
904 -- because of hierarchical module names.
905 splitQualName orig_buf len = split orig_buf orig_buf
908 | orig_buf `byteDiff` buf >= len = done dot_buf
909 | c == '.' = found_dot buf'
910 | otherwise = split buf' dot_buf
912 (c,buf') = nextChar buf
914 -- careful, we might get names like M....
915 -- so, if the character after the dot is not upper-case, this is
916 -- the end of the qualifier part.
917 found_dot buf -- buf points after the '.'
918 | isUpper c = split buf' buf
919 | otherwise = done buf
921 (c,buf') = nextChar buf
924 (lexemeToFastString orig_buf (qual_size - 1),
925 lexemeToFastString dot_buf (len - qual_size))
927 qual_size = orig_buf `byteDiff` dot_buf
931 case lookupUFM reservedWordsFM fs of
932 Just (keyword,0) -> do
934 return (L span keyword)
935 Just (keyword,exts) -> do
936 b <- extension (\i -> exts .&. i /= 0)
937 if b then do maybe_layout keyword
938 return (L span keyword)
939 else return (L span (ITvarid fs))
940 _other -> return (L span (ITvarid fs))
942 fs = lexemeToFastString buf len
944 conid buf len = ITconid fs
945 where fs = lexemeToFastString buf len
947 qvarsym buf len = ITqvarsym $! splitQualName buf len
948 qconsym buf len = ITqconsym $! splitQualName buf len
950 varsym = sym ITvarsym
951 consym = sym ITconsym
953 sym con span buf len =
954 case lookupUFM reservedSymsFM fs of
955 Just (keyword,exts) -> do
957 if b then return (L span keyword)
958 else return (L span $! con fs)
959 _other -> return (L span $! con fs)
961 fs = lexemeToFastString buf len
963 -- Variations on the integral numeric literal.
964 tok_integral :: (Integer -> Token)
965 -> (Integer -> Integer)
966 -- -> (StringBuffer -> StringBuffer) -> (Int -> Int)
968 -> (Integer, (Char->Int)) -> Action
969 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
970 return $ L span $ itint $! transint $ parseUnsignedInteger
971 (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
973 -- some conveniences for use with tok_integral
974 tok_num = tok_integral ITinteger
975 tok_primint = tok_integral ITprimint
978 decimal = (10,octDecDigit)
979 octal = (8,octDecDigit)
980 hexadecimal = (16,hexDigit)
982 -- readRational can understand negative rationals, exponents, everything.
983 tok_float str = ITrational $! readRational str
984 tok_primfloat str = ITprimfloat $! readRational str
985 tok_primdouble str = ITprimdouble $! readRational str
987 -- -----------------------------------------------------------------------------
990 -- we're at the first token on a line, insert layout tokens if necessary
992 do_bol span _str _len = do
996 --trace "layout: inserting '}'" $ do
998 -- do NOT pop the lex state, we might have a ';' to insert
999 return (L span ITvccurly)
1001 --trace "layout: inserting ';'" $ do
1003 return (L span ITsemi)
1008 -- certain keywords put us in the "layout" state, where we might
1009 -- add an opening curly brace.
1010 maybe_layout ITdo = pushLexState layout_do
1011 maybe_layout ITmdo = pushLexState layout_do
1012 maybe_layout ITof = pushLexState layout
1013 maybe_layout ITlet = pushLexState layout
1014 maybe_layout ITwhere = pushLexState layout
1015 maybe_layout ITrec = pushLexState layout
1016 maybe_layout _ = return ()
1018 -- Pushing a new implicit layout context. If the indentation of the
1019 -- next token is not greater than the previous layout context, then
1020 -- Haskell 98 says that the new layout context should be empty; that is
1021 -- the lexer must generate {}.
1023 -- We are slightly more lenient than this: when the new context is started
1024 -- by a 'do', then we allow the new context to be at the same indentation as
1025 -- the previous context. This is what the 'strict' argument is for.
1027 new_layout_context strict span _buf _len = do
1029 (AI _ offset _) <- getInput
1032 Layout prev_off : _ |
1033 (strict && prev_off >= offset ||
1034 not strict && prev_off > offset) -> do
1035 -- token is indented to the left of the previous context.
1036 -- we must generate a {} sequence now.
1037 pushLexState layout_left
1038 return (L span ITvocurly)
1040 setContext (Layout offset : ctx)
1041 return (L span ITvocurly)
1043 do_layout_left span _buf _len = do
1045 pushLexState bol -- we must be at the start of a line
1046 return (L span ITvccurly)
1048 -- -----------------------------------------------------------------------------
1051 setLine :: Int -> Action
1052 setLine code span buf len = do
1053 let line = parseUnsignedInteger buf len 10 octDecDigit
1054 setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
1055 -- subtract one: the line number refers to the *following* line
1060 setFile :: Int -> Action
1061 setFile code span buf len = do
1062 let file = lexemeToFastString (stepOn buf) (len-2)
1063 setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1069 -- -----------------------------------------------------------------------------
1070 -- Options, includes and language pragmas.
1072 lex_string_prag :: (String -> Token) -> Action
1073 lex_string_prag mkTok span _buf _len
1074 = do input <- getInput
1078 return (L (mkSrcSpan start end) tok)
1080 = if isString input "#-}"
1081 then do setInput input
1082 return (mkTok (reverse acc))
1083 else case alexGetChar input of
1084 Just (c,i) -> go (c:acc) i
1085 Nothing -> err input
1086 isString _ [] = True
1088 = case alexGetChar i of
1089 Just (c,i') | c == x -> isString i' xs
1091 err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1094 -- -----------------------------------------------------------------------------
1097 -- This stuff is horrible. I hates it.
1099 lex_string_tok :: Action
1100 lex_string_tok span _buf _len = do
1101 tok <- lex_string ""
1103 return (L (mkSrcSpan (srcSpanStart span) end) tok)
1105 lex_string :: String -> P Token
1108 case alexGetChar' i of
1109 Nothing -> lit_error
1113 magicHash <- extension magicHashEnabled
1117 case alexGetChar' i of
1121 then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1122 else let s' = mkZFastString (reverse s) in
1123 return (ITprimstring s')
1124 -- mkZFastString is a hack to avoid encoding the
1125 -- string in UTF-8. We just want the exact bytes.
1127 return (ITstring (mkFastString (reverse s)))
1129 return (ITstring (mkFastString (reverse s)))
1132 | Just ('&',i) <- next -> do
1133 setInput i; lex_string s
1134 | Just (c,i) <- next, is_space c -> do
1135 setInput i; lex_stringgap s
1136 where next = alexGetChar' i
1142 lex_stringgap s = do
1145 '\\' -> lex_string s
1146 c | is_space c -> lex_stringgap s
1150 lex_char_tok :: Action
1151 -- Here we are basically parsing character literals, such as 'x' or '\n'
1152 -- but, when Template Haskell is on, we additionally spot
1153 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
1154 -- but WIHTOUT CONSUMING the x or T part (the parser does that).
1155 -- So we have to do two characters of lookahead: when we see 'x we need to
1156 -- see if there's a trailing quote
1157 lex_char_tok span _buf _len = do -- We've seen '
1158 i1 <- getInput -- Look ahead to first character
1159 let loc = srcSpanStart span
1160 case alexGetChar' i1 of
1161 Nothing -> lit_error
1163 Just ('\'', i2@(AI end2 _ _)) -> do -- We've seen ''
1164 th_exts <- extension thEnabled
1167 return (L (mkSrcSpan loc end2) ITtyQuote)
1170 Just ('\\', i2@(AI _end2 _ _)) -> do -- We've seen 'backslash
1172 lit_ch <- lex_escape
1173 mc <- getCharOrFail -- Trailing quote
1174 if mc == '\'' then finish_char_tok loc lit_ch
1175 else do setInput i2; lit_error
1177 Just (c, i2@(AI _end2 _ _))
1178 | not (isAny c) -> lit_error
1181 -- We've seen 'x, where x is a valid character
1182 -- (i.e. not newline etc) but not a quote or backslash
1183 case alexGetChar' i2 of -- Look ahead one more character
1184 Nothing -> lit_error
1185 Just ('\'', i3) -> do -- We've seen 'x'
1187 finish_char_tok loc c
1188 _other -> do -- We've seen 'x not followed by quote
1189 -- If TH is on, just parse the quote only
1190 th_exts <- extension thEnabled
1191 let (AI end _ _) = i1
1192 if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1193 else do setInput i2; lit_error
1195 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1196 finish_char_tok loc ch -- We've already seen the closing quote
1197 -- Just need to check for trailing #
1198 = do magicHash <- extension magicHashEnabled
1199 i@(AI end _ _) <- getInput
1200 if magicHash then do
1201 case alexGetChar' i of
1202 Just ('#',i@(AI end _ _)) -> do
1204 return (L (mkSrcSpan loc end) (ITprimchar ch))
1206 return (L (mkSrcSpan loc end) (ITchar ch))
1208 return (L (mkSrcSpan loc end) (ITchar ch))
1210 lex_char :: Char -> AlexInput -> P Char
1213 '\\' -> do setInput inp; lex_escape
1214 c | isAny c -> do setInput inp; return c
1217 isAny c | c > '\xff' = isPrint c
1218 | otherwise = is_any c
1220 lex_escape :: P Char
1234 '^' -> do c <- getCharOrFail
1235 if c >= '@' && c <= '_'
1236 then return (chr (ord c - ord '@'))
1239 'x' -> readNum is_hexdigit 16 hexDigit
1240 'o' -> readNum is_octdigit 8 octDecDigit
1241 x | is_digit x -> readNum2 is_digit 10 octDecDigit (octDecDigit x)
1245 case alexGetChar' i of
1246 Nothing -> lit_error
1248 case alexGetChar' i2 of
1249 Nothing -> do setInput i2; lit_error
1251 let str = [c1,c2,c3] in
1252 case [ (c,rest) | (p,c) <- silly_escape_chars,
1253 Just rest <- [maybePrefixMatch p str] ] of
1254 (escape_char,[]):_ -> do
1257 (escape_char,_:_):_ -> do
1262 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1263 readNum is_digit base conv = do
1267 then readNum2 is_digit base conv (conv c)
1268 else do setInput i; lit_error
1270 readNum2 is_digit base conv i = do
1273 where read i input = do
1274 case alexGetChar' input of
1275 Just (c,input') | is_digit c -> do
1276 read (i*base + conv c) input'
1278 if i >= 0 && i <= 0x10FFFF
1279 then do setInput input; return (chr i)
1282 silly_escape_chars = [
1319 -- before calling lit_error, ensure that the current input is pointing to
1320 -- the position of the error in the buffer. This is so that we can report
1321 -- a correct location to the user, but also so we can detect UTF-8 decoding
1322 -- errors if they occur.
1323 lit_error = lexError "lexical error in string/character literal"
1325 getCharOrFail :: P Char
1328 case alexGetChar' i of
1329 Nothing -> lexError "unexpected end-of-file in string/character literal"
1330 Just (c,i) -> do setInput i; return c
1332 -- -----------------------------------------------------------------------------
1335 lex_quasiquote_tok :: Action
1336 lex_quasiquote_tok span buf len = do
1337 let quoter = reverse $ takeWhile (/= '$')
1338 $ reverse $ lexemeToString buf (len - 1)
1339 quoteStart <- getSrcLoc
1340 quote <- lex_quasiquote ""
1342 return (L (mkSrcSpan (srcSpanStart span) end)
1343 (ITquasiQuote (mkFastString quoter,
1344 mkFastString (reverse quote),
1345 mkSrcSpan quoteStart end)))
1347 lex_quasiquote :: String -> P String
1348 lex_quasiquote s = do
1350 case alexGetChar' i of
1351 Nothing -> lit_error
1354 | Just ('|',i) <- next -> do
1355 setInput i; lex_quasiquote ('|' : s)
1356 | Just (']',i) <- next -> do
1357 setInput i; lex_quasiquote (']' : s)
1358 where next = alexGetChar' i
1361 | Just (']',i) <- next -> do
1362 setInput i; return s
1363 where next = alexGetChar' i
1366 setInput i; lex_quasiquote (c : s)
1368 -- -----------------------------------------------------------------------------
1371 warn :: DynFlag -> SDoc -> Action
1372 warn option warning srcspan _buf _len = do
1373 addWarning option srcspan warning
1376 -- -----------------------------------------------------------------------------
1387 SrcSpan -- The start and end of the text span related to
1388 -- the error. Might be used in environments which can
1389 -- show this span, e.g. by highlighting it.
1390 Message -- The error message
1392 data PState = PState {
1393 buffer :: StringBuffer,
1395 messages :: Messages,
1396 last_loc :: SrcSpan, -- pos of previous token
1397 last_offs :: !Int, -- offset of the previous token from the
1398 -- beginning of the current line.
1399 -- \t is equal to 8 spaces.
1400 last_len :: !Int, -- len of previous token
1401 last_line_len :: !Int,
1402 loc :: SrcLoc, -- current loc (end of prev token + 1)
1403 extsBitmap :: !Int, -- bitmap that determines permitted extensions
1404 context :: [LayoutContext],
1407 -- last_loc and last_len are used when generating error messages,
1408 -- and in pushCurrentContext only. Sigh, if only Happy passed the
1409 -- current token to happyError, we could at least get rid of last_len.
1410 -- Getting rid of last_loc would require finding another way to
1411 -- implement pushCurrentContext (which is only called from one place).
1413 newtype P a = P { unP :: PState -> ParseResult a }
1415 instance Monad P where
1421 returnP a = a `seq` (P $ \s -> POk s a)
1423 thenP :: P a -> (a -> P b) -> P b
1424 (P m) `thenP` k = P $ \ s ->
1426 POk s1 a -> (unP (k a)) s1
1427 PFailed span err -> PFailed span err
1429 failP :: String -> P a
1430 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1432 failMsgP :: String -> P a
1433 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1435 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1436 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
1438 failSpanMsgP :: SrcSpan -> SDoc -> P a
1439 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1441 extension :: (Int -> Bool) -> P Bool
1442 extension p = P $ \s -> POk s (p $! extsBitmap s)
1445 getExts = P $ \s -> POk s (extsBitmap s)
1447 setSrcLoc :: SrcLoc -> P ()
1448 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1450 getSrcLoc :: P SrcLoc
1451 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1453 setLastToken :: SrcSpan -> Int -> Int -> P ()
1454 setLastToken loc len line_len = P $ \s -> POk s {
1457 last_line_len=line_len
1460 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
1462 alexInputPrevChar :: AlexInput -> Char
1463 alexInputPrevChar (AI _ _ buf) = prevChar buf '\n'
1465 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1466 alexGetChar (AI loc ofs s)
1468 | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
1469 --trace (show (ord c)) $
1470 Just (adj_c, (AI loc' ofs' s'))
1471 where (c,s') = nextChar s
1472 loc' = advanceSrcLoc loc c
1473 ofs' = advanceOffs c ofs
1481 other_graphic = '\x6'
1484 | c <= '\x06' = non_graphic
1486 -- Alex doesn't handle Unicode, so when Unicode
1487 -- character is encoutered we output these values
1488 -- with the actual character value hidden in the state.
1490 case generalCategory c of
1491 UppercaseLetter -> upper
1492 LowercaseLetter -> lower
1493 TitlecaseLetter -> upper
1494 ModifierLetter -> other_graphic
1495 OtherLetter -> other_graphic
1496 NonSpacingMark -> other_graphic
1497 SpacingCombiningMark -> other_graphic
1498 EnclosingMark -> other_graphic
1499 DecimalNumber -> digit
1500 LetterNumber -> other_graphic
1501 OtherNumber -> other_graphic
1502 ConnectorPunctuation -> other_graphic
1503 DashPunctuation -> other_graphic
1504 OpenPunctuation -> other_graphic
1505 ClosePunctuation -> other_graphic
1506 InitialQuote -> other_graphic
1507 FinalQuote -> other_graphic
1508 OtherPunctuation -> other_graphic
1509 MathSymbol -> symbol
1510 CurrencySymbol -> symbol
1511 ModifierSymbol -> symbol
1512 OtherSymbol -> symbol
1514 _other -> non_graphic
1516 -- This version does not squash unicode characters, it is used when
1518 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1519 alexGetChar' (AI loc ofs s)
1521 | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
1522 --trace (show (ord c)) $
1523 Just (c, (AI loc' ofs' s'))
1524 where (c,s') = nextChar s
1525 loc' = advanceSrcLoc loc c
1526 ofs' = advanceOffs c ofs
1528 advanceOffs :: Char -> Int -> Int
1529 advanceOffs '\n' _ = 0
1530 advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
1531 advanceOffs _ offs = offs + 1
1533 getInput :: P AlexInput
1534 getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b)
1536 setInput :: AlexInput -> P ()
1537 setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } ()
1539 pushLexState :: Int -> P ()
1540 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1542 popLexState :: P Int
1543 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1545 getLexState :: P Int
1546 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1548 -- for reasons of efficiency, flags indicating language extensions (eg,
1549 -- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
1552 genericsBit, ffiBit, parrBit :: Int
1553 genericsBit = 0 -- {| and |}
1559 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1560 bangPatBit = 8 -- Tells the parser to understand bang-patterns
1561 -- (doesn't affect the lexer)
1562 tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs
1563 haddockBit = 10 -- Lex and parse Haddock comments
1564 magicHashBit = 11 -- # in both functions and operators
1565 kindSigsBit = 12 -- Kind signatures on type variables
1566 recursiveDoBit = 13 -- mdo
1567 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1568 unboxedTuplesBit = 15 -- (# and #)
1569 standaloneDerivingBit = 16 -- standalone instance deriving declarations
1570 transformComprehensionsBit = 17
1571 qqBit = 18 -- enable quasiquoting
1573 genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1575 genericsEnabled flags = testBit flags genericsBit
1576 ffiEnabled flags = testBit flags ffiBit
1577 parrEnabled flags = testBit flags parrBit
1578 arrowsEnabled flags = testBit flags arrowsBit
1579 thEnabled flags = testBit flags thBit
1580 ipEnabled flags = testBit flags ipBit
1581 explicitForallEnabled flags = testBit flags explicitForallBit
1582 bangPatEnabled flags = testBit flags bangPatBit
1583 tyFamEnabled flags = testBit flags tyFamBit
1584 haddockEnabled flags = testBit flags haddockBit
1585 magicHashEnabled flags = testBit flags magicHashBit
1586 kindSigsEnabled flags = testBit flags kindSigsBit
1587 recursiveDoEnabled flags = testBit flags recursiveDoBit
1588 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1589 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1590 standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
1591 transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
1592 qqEnabled flags = testBit flags qqBit
1594 -- PState for parsing options pragmas
1596 pragState :: StringBuffer -> SrcLoc -> PState
1600 messages = emptyMessages,
1601 -- XXX defaultDynFlags is not right, but we don't have a real
1603 dflags = defaultDynFlags,
1604 last_loc = mkSrcSpan loc loc,
1611 lex_state = [bol, option_prags, 0]
1615 -- create a parse state
1617 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
1618 mkPState buf loc flags =
1622 messages = emptyMessages,
1623 last_loc = mkSrcSpan loc loc,
1628 extsBitmap = fromIntegral bitmap,
1630 lex_state = [bol, 0]
1631 -- we begin in the layout state if toplev_layout is set
1634 bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
1635 .|. ffiBit `setBitIf` dopt Opt_ForeignFunctionInterface flags
1636 .|. parrBit `setBitIf` dopt Opt_PArr flags
1637 .|. arrowsBit `setBitIf` dopt Opt_Arrows flags
1638 .|. thBit `setBitIf` dopt Opt_TemplateHaskell flags
1639 .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags
1640 .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
1641 .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
1642 .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
1643 .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
1644 .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
1645 .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
1646 .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
1647 .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
1648 .|. haddockBit `setBitIf` dopt Opt_Haddock flags
1649 .|. magicHashBit `setBitIf` dopt Opt_MagicHash flags
1650 .|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
1651 .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
1652 .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
1653 .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
1654 .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
1655 .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
1657 setBitIf :: Int -> Bool -> Int
1658 b `setBitIf` cond | cond = bit b
1661 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
1662 addWarning option srcspan warning
1663 = P $ \s@PState{messages=(ws,es), dflags=d} ->
1664 let warning' = mkWarnMsg srcspan alwaysQualify warning
1665 ws' = if dopt option d then ws `snocBag` warning' else ws
1666 in POk s{messages=(ws', es)} ()
1668 getMessages :: PState -> Messages
1669 getMessages PState{messages=ms} = ms
1671 getContext :: P [LayoutContext]
1672 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1674 setContext :: [LayoutContext] -> P ()
1675 setContext ctx = P $ \s -> POk s{context=ctx} ()
1678 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1679 last_len = len, last_loc = last_loc }) ->
1681 (_:tl) -> POk s{ context = tl } ()
1682 [] -> PFailed last_loc (srcParseErr buf len)
1684 -- Push a new layout context at the indentation of the last token read.
1685 -- This is only used at the outer level of a module when the 'module'
1686 -- keyword is missing.
1687 pushCurrentContext :: P ()
1688 pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } ->
1689 POk s{context = Layout (offs-len) : ctx} ()
1690 --trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
1692 getOffside :: P Ordering
1693 getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
1694 let ord = case stk of
1695 (Layout n:_) -> compare offs n
1699 -- ---------------------------------------------------------------------------
1700 -- Construct a parse error
1703 :: StringBuffer -- current buffer (placed just after the last token)
1704 -> Int -- length of the previous token
1707 = hcat [ if null token
1708 then ptext SLIT("parse error (possibly incorrect indentation)")
1709 else hcat [ptext SLIT("parse error on input "),
1710 char '`', text token, char '\'']
1712 where token = lexemeToString (offsetBytes (-len) buf) len
1714 -- Report a parse failure, giving the span of the previous token as
1715 -- the location of the error. This is the entry point for errors
1716 -- detected during parsing.
1718 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1719 last_loc = last_loc } ->
1720 PFailed last_loc (srcParseErr buf len)
1722 -- A lexical error is reported at a particular position in the source file,
1723 -- not over a token range.
1724 lexError :: String -> P a
1727 (AI end _ buf) <- getInput
1728 reportLexError loc end buf str
1730 -- -----------------------------------------------------------------------------
1731 -- This is the top-level function: called from the parser each time a
1732 -- new token is to be read from the input.
1734 lexer :: (Located Token -> P a) -> P a
1736 tok@(L _span _tok__) <- lexToken
1737 -- trace ("token: " ++ show tok__) $ do
1740 lexToken :: P (Located Token)
1742 inp@(AI loc1 _ buf) <- getInput
1745 case alexScanUser exts inp sc of
1747 let span = mkSrcSpan loc1 loc1
1748 setLastToken span 0 0
1749 return (L span ITeof)
1750 AlexError (AI loc2 _ buf) ->
1751 reportLexError loc1 loc2 buf "lexical error"
1752 AlexSkip inp2 _ -> do
1755 AlexToken inp2@(AI end _ buf2) _ t -> do
1757 let span = mkSrcSpan loc1 end
1758 let bytes = byteDiff buf buf2
1759 span `seq` setLastToken span bytes bytes
1762 reportLexError loc1 loc2 buf str
1763 | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
1766 c = fst (nextChar buf)
1768 if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
1769 then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
1770 else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)