[commit: ghc] master: Add layout to MultiWayIf (#7783) (aab6560)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/aab65608f9a26990b2c5083e4b65b9d1f6c9b48a/ghc

>---------------------------------------------------------------

commit aab65608f9a26990b2c5083e4b65b9d1f6c9b48a
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Fri Sep 27 20:59:41 2013 +0100

    Add layout to MultiWayIf (#7783)
    
    This makes it possible to write
    
    x = if | False -> if | False -> 1
                         | False -> 2
           | True -> 3
    
    Layout normally inserts semicolons between declarations at the same
    indentation level, so I added optional semicolons to the syntax for
    guards in MultiWayIf syntax.  This is a bit of a hack, but the
    alternative (a special kind of layout that doesn't insert semicolons)
    seemed worse, or at least equally bad.


>---------------------------------------------------------------

aab65608f9a26990b2c5083e4b65b9d1f6c9b48a
 compiler/parser/Lexer.x     |   23 +++++++++++++++--------
 compiler/parser/Parser.y.pp |   15 ++++++++++++++-
 2 files changed, 29 insertions(+), 9 deletions(-)

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 41ba1d8..79ba027 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -219,16 +219,22 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 -- after a layout keyword (let, where, do, of), we begin a new layout
 -- context if the curly brace is missing.
 -- Careful! This stuff is quite delicate.
-<layout, layout_do> {
+<layout, layout_do, layout_if> {
   \{ / { notFollowedBy '-' }            { hopefully_open_brace }
         -- we might encounter {-# here, but {- has been handled already
   \n                                    ;
   ^\# (line)?                           { begin line_prag1 }
 }
 
+-- after an 'if', a vertical bar starts a layout context for MultiWayIf
+<layout_if> {
+  \| / { notFollowedBySymbol }          { new_layout_context True ITvbar }
+  ()                                    { pop }
+}
+
 -- do is treated in a subtly different way, see new_layout_context
-<layout>    ()                          { new_layout_context True }
-<layout_do> ()                          { new_layout_context False }
+<layout>    ()                          { new_layout_context True  ITvocurly }
+<layout_do> ()                          { new_layout_context False 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
@@ -1143,6 +1149,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
           f ITlet   = pushLexState layout
           f ITwhere = pushLexState layout
           f ITrec   = pushLexState layout
+          f ITif    = pushLexState layout_if
           f _       = return ()
 
 -- Pushing a new implicit layout context.  If the indentation of the
@@ -1154,11 +1161,11 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
 -- 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 -> Action
-new_layout_context strict span _buf _len = do
+new_layout_context :: Bool -> Token -> Action
+new_layout_context strict tok span _buf len = do
     _ <- popLexState
     (AI l _) <- getInput
-    let offset = srcLocCol l
+    let offset = srcLocCol l - len
     ctx <- getContext
     nondecreasing <- extension nondecreasingIndentation
     let strict' = strict || not nondecreasing
@@ -1169,10 +1176,10 @@ new_layout_context strict span _buf _len = do
                 -- token is indented to the left of the previous context.
                 -- we must generate a {} sequence now.
                 pushLexState layout_left
-                return (L span ITvocurly)
+                return (L span tok)
         _ -> do
                 setContext (Layout offset : ctx)
-                return (L span ITvocurly)
+                return (L span tok)
 
 do_layout_left :: Action
 do_layout_left span _buf _len = do
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index ea192a0..c2ddf45 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1459,7 +1459,7 @@ exp10 :: { LHsExpr RdrName }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
                                            return (LL $ mkHsIf $2 $5 $8) }
-        | 'if' gdpats                   {% hintMultiWayIf (getLoc $1) >>
+        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
                                            return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) }
         | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
         | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
@@ -1754,6 +1754,19 @@ gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
         : gdpats gdpat                  { LL ($2 : unLoc $1) }
         | gdpat                         { L1 [$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      { sL (comb2 $1 $2) ($2 : unLoc $1) }
+        | gdpat optSemi                 { L1 [$1] }
+
+-- 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 [LGRHS RdrName (LHsExpr RdrName)] }
+         : '{' gdpatssemi '}'              { LL (unLoc $2) }
+         |     gdpatssemi close            { $1 }
+
 gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }
         : '|' guardquals '->' exp               { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }