X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=952196af7560716ed9ea300e02d86b05b45eb5b6;hb=fb8bf8536a4b72b59cb7a3fc26c5787f3b80348d;hp=66f4fe51366d36d60087e99ef2b32eba25c2f8cb;hpb=c0f542271da944d540faf91678c48ff856174b57;p=ghc-hetmet.git diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 66f4fe5..952196a 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -20,6 +20,17 @@ -- - M... should be 3 tokens, not 1. -- - pragma-end should be only valid in a pragma +-- qualified operator NOTES. +-- +-- - If M.(+) is a single lexeme, then.. +-- - Probably (+) should be a single lexeme too, for consistency. +-- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. +-- - But we have to rule out reserved operators, otherwise (..) becomes +-- a different lexeme. +-- - Should we therefore also rule out reserved operators in the qualified +-- form? This is quite difficult to achieve. We don't do it for +-- qualified varids. + { {-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. @@ -41,7 +52,8 @@ module Lexer ( popContext, pushCurrentContext, setLastToken, setSrcLoc, getLexState, popLexState, pushLexState, extension, standaloneDerivingEnabled, bangPatEnabled, - addWarning + addWarning, + lexTokenStream ) where import Bag @@ -58,11 +70,9 @@ import Util ( maybePrefixMatch, readRational ) import Control.Monad import Data.Bits -import Data.Char ( chr, ord, isSpace ) +import Data.Char import Data.Ratio import Debug.Trace - -import Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper ) } $unispace = \x05 -- Trick Alex into handling Unicode. See alexGetChar. @@ -148,12 +158,12 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- space followed by a Haddock comment symbol (docsym) (in which case we'd -- have a Haddock comment). The rules then munch the rest of the line. -"-- " ~[$docsym \#] .* ; -"--" [^$symbol : \ ] .* ; +"-- " ~[$docsym \#] .* { lineCommentToken } +"--" [^$symbol : \ ] .* { lineCommentToken } -- Next, match Haddock comments if no -haddock flag -"-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } ; +"-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } { lineCommentToken } -- Now, when we've matched comments that begin with 2 dashes and continue -- with a different character, we need to match comments that begin with three @@ -161,17 +171,17 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- make sure that the first non-dash character isn't a symbol, and munch the -- rest of the line. -"---"\-* [^$symbol :] .* ; +"---"\-* [^$symbol :] .* { lineCommentToken } -- Since the previous rules all match dashes followed by at least one -- character, we also need to match a whole line filled with just dashes. -"--"\-* / { atEOL } ; +"--"\-* / { atEOL } { lineCommentToken } -- We need this rule since none of the other single line comment rules -- actually match this case. -"-- " / { atEOL } ; +"-- " / { atEOL } { lineCommentToken } -- 'bol' state: beginning of a line. Slurp up all the whitespace (including -- blank lines) until we find a non-whitespace character, then do layout @@ -228,7 +238,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- with older versions of GHC which generated these. <0,option_prags> { - "{-#" $whitechar* (RULES|rules) { token ITrules_prag } + "{-#" $whitechar* (RULES|rules) { rulePrag } "{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) } "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline) { token (ITinline_prag False) } @@ -249,6 +259,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } { token ITgenerated_prag } "{-#" $whitechar* (CORE|core) { token ITcore_prag } "{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag } + "{-#" $whitechar* (ANN|ann) { token ITann_prag } -- We ignore all these pragmas, but don't generate a warning for them -- CFILES is a hugs-only thing. @@ -277,7 +288,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } } <0> { - "-- #" .* ; + "-- #" .* { lineCommentToken } } <0,option_prags> { @@ -364,13 +375,15 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid } } --- ToDo: M.(,,,) - +-- ToDo: - move `var` and (sym) into lexical syntax? +-- - remove backquote from $special? <0> { - @qual @varsym { idtoken qvarsym } - @qual @consym { idtoken qconsym } - @varsym { varsym } - @consym { consym } + @qual @varsym / { ifExtension oldQualOps } { idtoken qvarsym } + @qual @consym / { ifExtension oldQualOps } { idtoken qconsym } + @qual \( @varsym \) / { ifExtension newQualOps } { idtoken prefixqvarsym } + @qual \( @consym \) / { ifExtension newQualOps } { idtoken prefixqconsym } + @varsym { varsym } + @consym { consym } } -- For the normal boxed literals we need to be careful @@ -476,6 +489,7 @@ data Token | ITgenerated_prag | ITcore_prag -- hdaume: core annotations | ITunpack_prag + | ITann_prag | ITclose_prag | IToptions_prag String | ITinclude_prag String @@ -526,6 +540,8 @@ data Token | ITqconid (FastString,FastString) | ITqvarsym (FastString,FastString) | ITqconsym (FastString,FastString) + | ITprefixqvarsym (FastString,FastString) + | ITprefixqconsym (FastString,FastString) | ITdupipvarid FastString -- GHC extension: implicit param: ?x @@ -575,6 +591,8 @@ data Token | ITdocSection Int String -- a section heading | ITdocOptions String -- doc options (prune, ignore-exports, etc) | ITdocOptionsOld String -- doc options declared "-- # ..."-style + | ITlineComment String -- comment starting by "--" + | ITblockComment String -- comment in {- -} #ifdef DEBUG deriving Show -- debugging @@ -802,6 +820,11 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") | otherwise -> input Nothing -> input +lineCommentToken :: Action +lineCommentToken span buf len = do + b <- extension rawTokenStreamEnabled + if b then strtoken ITlineComment span buf len else lexToken + {- nested comments require traversing by hand, they can't be parsed using regular expressions. @@ -809,20 +832,24 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") nested_comment :: P (Located Token) -> Action nested_comment cont span _str _len = do input <- getInput - go (1::Int) input + go "" (1::Int) input where - go 0 input = do setInput input; cont - go n input = case alexGetChar input of + go commentAcc 0 input = do setInput input + b <- extension rawTokenStreamEnabled + if b + then docCommentEnd input commentAcc ITblockComment _str span + else cont + go commentAcc n input = case alexGetChar input of Nothing -> errBrace input span Just ('-',input) -> case alexGetChar input of Nothing -> errBrace input span - Just ('\125',input) -> go (n-1) input - Just (_,_) -> go n input + Just ('\125',input) -> go commentAcc (n-1) input + Just (_,_) -> go ('-':commentAcc) n input Just ('\123',input) -> case alexGetChar input of Nothing -> errBrace input span - Just ('-',input) -> go (n+1) input - Just (_,_) -> go n input - Just (_,input) -> go n input + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input nested_doc_comment :: Action nested_doc_comment span buf _len = withLexedDocType (go "") @@ -861,7 +888,7 @@ withLexedDocType lexDocComment = do -- off again at the end of the pragma. rulePrag :: Action rulePrag span buf len = do - setExts (.|. inRulePragBit) + setExts (.|. bit inRulePragBit) return (L span ITrules_prag) endPrag :: Action @@ -912,14 +939,14 @@ close_brace span _str _len = do popContext return (L span ITccurly) -qvarid buf len = ITqvarid $! splitQualName buf len -qconid buf len = ITqconid $! splitQualName buf len +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False -splitQualName :: StringBuffer -> Int -> (FastString,FastString) +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) -- takes a StringBuffer and a length, and returns the module name -- and identifier parts of a qualified name. Splits at the *last* dot, -- because of hierarchical module names. -splitQualName orig_buf len = split orig_buf orig_buf +splitQualName orig_buf len parens = split orig_buf orig_buf where split buf dot_buf | orig_buf `byteDiff` buf >= len = done dot_buf @@ -939,7 +966,9 @@ splitQualName orig_buf len = split orig_buf orig_buf done dot_buf = (lexemeToFastString orig_buf (qual_size - 1), - lexemeToFastString dot_buf (len - qual_size)) + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) where qual_size = orig_buf `byteDiff` dot_buf @@ -961,8 +990,10 @@ varid span buf len = conid buf len = ITconid fs where fs = lexemeToFastString buf len -qvarsym buf len = ITqvarsym $! splitQualName buf len -qconsym buf len = ITqconsym $! splitQualName buf len +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False +prefixqvarsym buf len = ITprefixqvarsym $! splitQualName buf len True +prefixqconsym buf len = ITprefixqconsym $! splitQualName buf len True varsym = sym ITvarsym consym = sym ITconsym @@ -1525,13 +1556,13 @@ alexGetChar (AI loc ofs s) DecimalNumber -> digit LetterNumber -> other_graphic OtherNumber -> other_graphic - ConnectorPunctuation -> other_graphic - DashPunctuation -> other_graphic + ConnectorPunctuation -> symbol + DashPunctuation -> symbol OpenPunctuation -> other_graphic ClosePunctuation -> other_graphic InitialQuote -> other_graphic FinalQuote -> other_graphic - OtherPunctuation -> other_graphic + OtherPunctuation -> symbol MathSymbol -> symbol CurrencySymbol -> symbol ModifierSymbol -> symbol @@ -1596,6 +1627,8 @@ standaloneDerivingBit = 16 -- standalone instance deriving declarations transformComprehensionsBit = 17 qqBit = 18 -- enable quasiquoting inRulePragBit = 19 +rawTokenStreamBit = 20 -- producing a token stream with all comments included +newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool always _ = True @@ -1618,6 +1651,9 @@ standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit qqEnabled flags = testBit flags qqBit inRulePrag flags = testBit flags inRulePragBit +rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit +newQualOps flags = testBit flags newQualOpsBit +oldQualOps flags = not (newQualOps flags) -- PState for parsing options pragmas -- @@ -1679,7 +1715,9 @@ mkPState buf loc flags = .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags - .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags + .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags + .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b @@ -1795,4 +1833,13 @@ reportLexError loc1 loc2 buf str if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + +lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream buf loc dflags = unP go initState + where initState = mkPState buf loc (dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream) + go = do + ltok <- lexer return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go }