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

2 files changed, 41 insertions, 36 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 436ffc9ce6..410d150f45 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -58,7 +58,7 @@ module Lexer (
    getPState, extopt, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
-   popContext, pushCurrentContext, setLastToken, setSrcLoc,
+   popContext, pushModuleContext, setLastToken, setSrcLoc,
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
@@ -285,13 +285,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
@@ -937,8 +937,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")
 
@@ -1292,18 +1292,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
 
@@ -1337,9 +1337,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
@@ -1347,15 +1346,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
@@ -1740,9 +1738,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
@@ -2327,19 +2335,24 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
         []     -> PFailed (RealSrcSpan last_loc) (srcParseErr o 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 b9479d9be0..5db535f20e 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -535,7 +535,7 @@ maybedocheader :: { Maybe LHsDocString }
         | {- empty -}             { Nothing }
 
 missing_module_keyword :: { () }
-        : {- empty -}                           {% pushCurrentContext }
+        : {- empty -}                           {% pushModuleContext }
 
 maybemodwarning :: { Maybe (Located WarningTxt) }
     : '{-# DEPRECATED' strings '#-}'
@@ -2603,20 +2603,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