Commit cb03d1cc authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Ben Gamari

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 c36904d6)
parent d2695b84
......@@ -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
<layout_if> {
\| / { 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
<layout> () { new_layout_context True ITvocurly }
<layout_do> () { new_layout_context False ITvocurly }
<layout> () { new_layout_context True generateSemic ITvocurly }
<layout_do> () { 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
-- ---------------------------------------------------------------------------
......
......@@ -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
......
{-# 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)
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment