From cb03d1ccd87a683cb7816a9d2d89a7722040c614 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= Date: Mon, 26 Sep 2016 17:09:01 -0400 Subject: [PATCH] Fix layout of MultiWayIf expressions (#10807) With this patch we stop generating virtual semicolons in MultiWayIf guards. Fixes #10807. Test Plan: Reviewers: simonmar, austin, bgamari Reviewed By: simonmar Subscribers: mpickering, thomie Differential Revision: https://phabricator.haskell.org/D2524 GHC Trac Issues: #10807 (cherry picked from commit c36904d66f30d4386a231ce365a056962a881767) --- compiler/parser/Lexer.x | 63 +++++++++++-------- compiler/parser/Parser.y | 14 +---- testsuite/tests/parser/should_run/T10807.hs | 43 +++++++++++++ .../tests/parser/should_run/T10807.stdout | 4 ++ testsuite/tests/parser/should_run/all.T | 3 +- 5 files changed, 90 insertions(+), 37 deletions(-) create mode 100644 testsuite/tests/parser/should_run/T10807.hs create mode 100644 testsuite/tests/parser/should_run/T10807.stdout diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 07d04343b9..d35343b3b1 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -58,7 +58,7 @@ module Lexer ( getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, getMessages, - popContext, pushCurrentContext, setLastToken, setSrcLoc, + popContext, pushModuleContext, setLastToken, setSrcLoc, activeContext, nextIsEOF, getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, @@ -286,13 +286,13 @@ $tab { warnTab } -- after an 'if', a vertical bar starts a layout context for MultiWayIf { - \| / { notFollowedBySymbol } { new_layout_context True ITvbar } + \| / { notFollowedBySymbol } { new_layout_context True dontGenerateSemic ITvbar } () { pop } } -- do is treated in a subtly different way, see new_layout_context - () { new_layout_context True ITvocurly } - () { new_layout_context False ITvocurly } + () { new_layout_context True generateSemic ITvocurly } + () { new_layout_context False generateSemic ITvocurly } -- after a new layout context which was found to be to the left of the -- previous context, we have generated a '{' token, and we now need to @@ -924,8 +924,8 @@ hopefully_open_brace span buf len let offset = srcLocCol l isOK = relaxed || case ctx of - Layout prev_off : _ -> prev_off < offset - _ -> True + Layout prev_off _ : _ -> prev_off < offset + _ -> True if isOK then pop_and open_brace span buf len else failSpanMsgP (RealSrcSpan span) (text "Missing block") @@ -1273,18 +1273,18 @@ readFractionalLit str = (FL $! str) $! readRational str -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action do_bol span _str _len = do - pos <- getOffside + (pos, gen_semic) <- getOffside case pos of LT -> do --trace "layout: inserting '}'" $ do popContext -- do NOT pop the lex state, we might have a ';' to insert return (L span ITvccurly) - EQ -> do + EQ | gen_semic -> do --trace "layout: inserting ';'" $ do _ <- popLexState return (L span ITsemi) - GT -> do + _ -> do _ <- popLexState lexToken @@ -1318,9 +1318,8 @@ maybe_layout t = do -- If the alternative layout rule is enabled then -- We are slightly more lenient than this: when the new context is started -- by a 'do', then we allow the new context to be at the same indentation as -- the previous context. This is what the 'strict' argument is for. --- -new_layout_context :: Bool -> Token -> Action -new_layout_context strict tok span _buf len = do +new_layout_context :: Bool -> Bool -> Token -> Action +new_layout_context strict gen_semic tok span _buf len = do _ <- popLexState (AI l _) <- getInput let offset = srcLocCol l - len @@ -1328,15 +1327,14 @@ new_layout_context strict tok span _buf len = do nondecreasing <- extension nondecreasingIndentation let strict' = strict || not nondecreasing case ctx of - Layout prev_off : _ | + Layout prev_off _ : _ | (strict' && prev_off >= offset || not strict' && prev_off > offset) -> do -- token is indented to the left of the previous context. -- we must generate a {} sequence now. pushLexState layout_left return (L span tok) - _ -> do - setContext (Layout offset : ctx) + _ -> do setContext (Layout offset gen_semic : ctx) return (L span tok) do_layout_left :: Action @@ -1721,9 +1719,19 @@ warnThen option warning action srcspan buf len = do -- ----------------------------------------------------------------------------- -- The Parse Monad +-- | Do we want to generate ';' layout tokens? In some cases we just want to +-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates +-- alternatives (unlike a `case` expression where we need ';' to as a separator +-- between alternatives). +type GenSemic = Bool + +generateSemic, dontGenerateSemic :: GenSemic +generateSemic = True +dontGenerateSemic = False + data LayoutContext = NoLayout - | Layout !Int + | Layout !Int !GenSemic deriving Show data ParseResult a @@ -2266,19 +2274,24 @@ popContext = P $ \ s@(PState{ buffer = buf, dflags = flags, context = ctx, [] -> PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len) -- Push a new layout context at the indentation of the last token read. --- This is only used at the outer level of a module when the 'module' --- keyword is missing. -pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{context = Layout (srcSpanStartCol loc) : ctx} () +pushCurrentContext :: GenSemic -> P () +pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () + +-- This is only used at the outer level of a module when the 'module' keyword is +-- missing. +pushModuleContext :: P () +pushModuleContext = pushCurrentContext generateSemic -getOffside :: P Ordering +getOffside :: P (Ordering, Bool) getOffside = P $ \s@PState{last_loc=loc, context=stk} -> let offs = srcSpanStartCol loc in let ord = case stk of - (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ - compare offs n - _ -> GT + Layout n gen_semic : _ -> + --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + (compare offs n, gen_semic) + _ -> + (GT, dontGenerateSemic) in POk s ord -- --------------------------------------------------------------------------- diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 1f3d1070be..6ebc8e6e29 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -536,7 +536,7 @@ maybedocheader :: { Maybe LHsDocString } | {- empty -} { Nothing } missing_module_keyword :: { () } - : {- empty -} {% pushCurrentContext } + : {- empty -} {% pushModuleContext } maybemodwarning :: { Maybe (Located WarningTxt) } : '{-# DEPRECATED' strings '#-}' @@ -2580,20 +2580,12 @@ gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) } | gdpat { sL1 $1 [$1] } --- optional semi-colons between the guards of a MultiWayIf, because we use --- layout here, but we don't need (or want) the semicolon as a separator (#7783). -gdpatssemi :: { Located [LGRHS RdrName (LHsExpr RdrName)] } - : gdpatssemi gdpat optSemi {% ams (sL (comb2 $1 $2) ($2 : unLoc $1)) - (map (\l -> mj AnnSemi l) $ fst $3) } - | gdpat optSemi {% ams (sL1 $1 [$1]) - (map (\l -> mj AnnSemi l) $ fst $2) } - -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to -- generate the open brace in addition to the vertical bar in the lexer, and -- we don't need it. ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) } - : '{' gdpatssemi '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } - | gdpatssemi close { sL1 $1 ([],unLoc $1) } + : '{' gdpats '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } + | gdpats close { sL1 $1 ([],unLoc $1) } gdpat :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '->' exp diff --git a/testsuite/tests/parser/should_run/T10807.hs b/testsuite/tests/parser/should_run/T10807.hs new file mode 100644 index 0000000000..8f6546201e --- /dev/null +++ b/testsuite/tests/parser/should_run/T10807.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE MultiWayIf #-} + +module Main where + +-- This is how we had to use multi-way if previously. Not indenting lines after +-- `|` was causing a parse error. +f1 x = if | even x + , x /= 0 + -> True + | otherwise + -> False + +-- This was previously causing a parse error, but actually it should work. +f2 x = if | even x + , x /= 0 + -> True + | otherwise + -> False + +-- If we don't generate {} in MultiWayIf we get a shift/reduce conflict here: +-- It's not clear which guards belong to `case` and which ones belong to `if`. +-- +-- This test is to make sure we parse it correctly. +-- +-- - If we shift, we get a non-exhaustive pattern error when argument is odd. +-- - If we reduce, we run the unreachable code when argument is odd. +f3 x = case x of + x' | even x' -> if | even x' -> 1 | otherwise -> error "should be unreachable" + | otherwise -> 3 + +-- Testing line breaks +f4 x = case x of + x' | even x' -> if + | even x' -> 1 + | otherwise -> error "should be unreachable" + | otherwise -> 3 + +main :: IO () +main = do + print (f3 1) + print (f3 2) + print (f4 1) + print (f4 2) diff --git a/testsuite/tests/parser/should_run/T10807.stdout b/testsuite/tests/parser/should_run/T10807.stdout new file mode 100644 index 0000000000..9fcb40e7af --- /dev/null +++ b/testsuite/tests/parser/should_run/T10807.stdout @@ -0,0 +1,4 @@ +3 +1 +3 +1 diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T index cf7ee6fdd3..fa354fef4a 100644 --- a/testsuite/tests/parser/should_run/all.T +++ b/testsuite/tests/parser/should_run/all.T @@ -8,4 +8,5 @@ test('operator2', normal, compile_and_run, ['']) test('ParserMultiWayIf', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, ['']) test('BinaryLiterals0', normal, compile_and_run, ['']) test('BinaryLiterals1', when(compiler_lt('ghc', '7.9'), skip), compile_and_run, ['']) -test('BinaryLiterals2', when(compiler_lt('ghc', '7.9'), skip), compile_and_run, ['']) \ No newline at end of file +test('BinaryLiterals2', when(compiler_lt('ghc', '7.9'), skip), compile_and_run, ['']) +test('T10807', normal, compile_and_run, ['']) -- GitLab