X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=6cb2c3b7ca2c40f8f9c8c10b9f13be4d33432af9;hp=51aa2f397f1f01fa99544604f2a4dd8c7e60fbd7;hb=4bba92f93b88e15f0e0f23732d2cfa540acb737b;hpb=fa306a37eaae1020f4cbd6cbed04847db6c23273 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 51aa2f3..6cb2c3b 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -307,7 +307,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } "$(" / { ifExtension thEnabled } { token ITparenEscape } - "[$" @varid "|" / { ifExtension qqEnabled } + "[" @varid "|" / { ifExtension qqEnabled } { lex_quasiquote_tok } } @@ -1412,8 +1412,9 @@ getCharOrFail i = do lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do - let quoter = reverse $ takeWhile (/= '$') - $ reverse $ lexemeToString buf (len - 1) + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' quoteStart <- getSrcLoc quote <- lex_quasiquote "" end <- getSrcLoc @@ -1496,7 +1497,10 @@ data PState = PState { alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells -- us what sort of layout the '{' will open: - alr_expecting_ocurly :: Maybe ALRLayout + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1505,6 +1509,7 @@ data PState = PState { -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} | ALRLayout ALRLayout Int data ALRLayout = ALRLayoutLet | ALRLayoutWhere @@ -1669,6 +1674,14 @@ getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs setALRContext :: [ALRContext] -> P () setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + setNextToken :: Located Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () @@ -1801,7 +1814,8 @@ pragState dynflags buf loc = alr_next_token = Nothing, alr_last_loc = noSrcSpan, alr_context = [], - alr_expecting_ocurly = Nothing + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False } @@ -1824,7 +1838,8 @@ mkPState buf loc flags = alr_next_token = Nothing, alr_last_loc = noSrcSpan, alr_context = [], - alr_expecting_ocurly = Nothing + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False } where bitmap = genericsBit `setBitIf` dopt Opt_Generics flags @@ -1964,16 +1979,23 @@ alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc mExpectingOCurly <- getAlrExpectingOCurly - let thisLoc = getLoc t + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + dflags <- getDynFlags + let transitional = dopt Opt_AlternativeLayoutRuleTransitional dflags + thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc newLine = (lastLoc == noSrcSpan) || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) case (unLoc t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... - (ITocurly, _, Just _) -> + (ITocurly, _, Just alrLayout) -> do setAlrExpectingOCurly Nothing - setALRContext (ALRNoLayout (containsCommas ITocurly) : context) + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) return t -- ...and makes this case unnecessary {- @@ -2012,11 +2034,38 @@ alternativeLayoutRuleToken t (ITeof, _, _) -> return t -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) | newLine -> do setPendingImplicitTokens [t] setALRContext ls return (L thisLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + thisLoc + (transitionalAlternativeLayoutWarning + "`where' clause at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + thisLoc + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) (_, ALRLayout _ col : ls, _) | newLine && thisCol == col -> do setNextToken t @@ -2027,10 +2076,8 @@ alternativeLayoutRuleToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITccurly) - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) : context) - return t + -- We need to handle close before open, as 'then' is both + -- an open and a close (u, _, _) | isALRclose u -> case context of @@ -2038,13 +2085,25 @@ alternativeLayoutRuleToken t do setALRContext ls setNextToken t return (L thisLoc ITccurly) - ALRNoLayout _ : ls -> - do setALRContext ls + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True return t [] -> - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else ls + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> do setALRContext ls setPendingImplicitTokens [t] @@ -2066,9 +2125,15 @@ alternativeLayoutRuleToken t -- the other ITwhere case omitted; general case below covers it (_, _, _) -> return t +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + isALRopen :: Token -> Bool isALRopen ITcase = True isALRopen ITif = True +isALRopen ITthen = True isALRopen IToparen = True isALRopen ITobrack = True isALRopen ITocurly = True @@ -2080,6 +2145,7 @@ isALRopen _ = False isALRclose :: Token -> Bool isALRclose ITof = True isALRclose ITthen = True +isALRclose ITelse = True isALRclose ITcparen = True isALRclose ITcbrack = True isALRclose ITccurly = True @@ -2105,7 +2171,7 @@ containsCommas _ = False topNoLayoutContainsCommas :: [ALRContext] -> Bool topNoLayoutContainsCommas [] = False topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls -topNoLayoutContainsCommas (ALRNoLayout b : _) = b +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b lexToken :: P (Located Token) lexToken = do