Implement BlockArguments (#10843)

This patch implements the BlockArguments extension, as proposed at
https://github.com/ghc-proposals/ghc-proposals/pull/90. It also
fixes #10855 as a side-effect.

This patch adds a large number of shift-reduce conflicts to the parser.
All of them concern the ambiguity as to where constructs like `if` and
`let` end. Fortunately they are resolved correctly by preferring shift.

The patch is based on @gibiansky's ArgumentDo implementation (D1219).

Test Plan: ./validate

Reviewers: goldfire, bgamari, alanz, mpickering

Reviewed By: bgamari, mpickering

Subscribers: Wizek, dfeuer, gibiansky, rwbarton, thomie, mpickering, carter

GHC Trac Issues: #10843, #10855

Differential Revision: https://phabricator.haskell.org/D4260

4 files changed, 154 insertions, 76 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e93a133cf6..cf889ecd72 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -4019,6 +4019,7 @@ xFlagsDeps = [
   flagSpec "DerivingStrategies"               LangExt.DerivingStrategies,
   flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,
   flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,
+  flagSpec "BlockArguments"                   LangExt.BlockArguments,
   depFlagSpec' "DoRec"                        LangExt.RecursiveDo
     (deprecatedForExtension "RecursiveDo"),
   flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 2f5eccd7e6..83beef210d 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1244,15 +1244,14 @@ varid :: Action
 varid span buf len =
   case lookupUFM reservedWordsFM fs of
     Just (ITcase, _) -> do
-      lambdaCase <- extension lambdaCaseEnabled
-      keyword <- if lambdaCase
-                 then do
-                   lastTk <- getLastTk
-                   return $ case lastTk of
-                     Just ITlam -> ITlcase
-                     _          -> ITcase
-                 else
-                   return ITcase
+      lastTk <- getLastTk
+      keyword <- case lastTk of
+        Just ITlam -> do
+          lambdaCase <- extension lambdaCaseEnabled
+          if lambdaCase
+            then return ITlcase
+            else failMsgP "Illegal lambda-case (use -XLambdaCase)"
+        _ -> return ITcase
       maybe_layout keyword
       return $ L span keyword
     Just (ITstatic, _) -> do
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index a3bc996c20..7f1a725b6b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -88,9 +88,9 @@ import GhcPrelude
 import qualified GHC.LanguageExtensions as LangExt
 }
 
-%expect 36 -- shift/reduce conflicts
+%expect 206 -- shift/reduce conflicts
 
-{- Last updated: 3 Aug 2016
+{- Last updated: 11 Dec 2017
 
 If you modify this parser and add a conflict, please update this comment.
 You can learn more about the conflicts by passing 'happy' the -i flag:
@@ -121,7 +121,7 @@ follows. Shift parses as if the 'module' keyword follows.
 
 -------------------------------------------------------------------------------
 
-state 48 contains 2 shift/reduce conflicts.
+state 56 contains 2 shift/reduce conflicts.
 
     *** strict_mark -> unpackedness .
         strict_mark -> unpackedness . strictness
@@ -130,7 +130,7 @@ state 48 contains 2 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 52 contains 1 shift/reduce conflict.
+state 60 contains 1 shift/reduce conflict.
 
         context -> btype .
     *** type -> btype .
@@ -140,16 +140,25 @@ state 52 contains 1 shift/reduce conflict.
 
 -------------------------------------------------------------------------------
 
-state 53 contains 9 shift/reduce conflicts.
+state 61 contains 45 shift/reduce conflicts.
 
     *** btype -> tyapps .
         tyapps -> tyapps . tyapp
 
-    Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+    Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE
+      VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM
+      STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE
+      and all the special ids.
+
+Example ambiguity:
+    'if x then y else z :: F a'
+
+Shift parses as (per longest-parse rule):
+    'if x then y else z :: (F a)'
 
 -------------------------------------------------------------------------------
 
-state 134 contains 14 shift/reduce conflicts.
+state 142 contains 14 shift/reduce conflicts.
 
         exp -> infixexp . '::' sigtype
         exp -> infixexp . '-<' exp
@@ -174,7 +183,25 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 299 contains 1 shift/reduce conflicts.
+state 147 contains 67 shift/reduce conflicts.
+
+    *** exp10 -> fexp .
+        fexp -> fexp . aexp
+        fexp -> fexp . TYPEAPP atype
+
+    Conflicts: TYPEAPP and all the tokens that can start an aexp
+
+Examples of ambiguity:
+    'if x then y else f z'
+    'if x then y else f @ z'
+
+Shift parses as (per longest-parse rule):
+    'if x then y else (f z)'
+    'if x then y else (f @ z)'
+
+-------------------------------------------------------------------------------
+
+state 307 contains 1 shift/reduce conflicts.
 
         rule -> STRING . rule_activation rule_forall infixexp '=' exp
 
@@ -192,18 +219,18 @@ a rule instructing how to rewrite the expression '[0] f'.
 
 -------------------------------------------------------------------------------
 
-state 309 contains 1 shift/reduce conflict.
+state 317 contains 1 shift/reduce conflict.
 
     *** type -> btype .
         type -> btype . '->' ctype
 
     Conflict: '->'
 
-Same as state 50 but without contexts.
+Same as state 60 but without contexts.
 
 -------------------------------------------------------------------------------
 
-state 348 contains 1 shift/reduce conflicts.
+state 357 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(' commas . ')'
@@ -218,7 +245,7 @@ if -XTupleSections is not specified.
 
 -------------------------------------------------------------------------------
 
-state 402 contains 1 shift/reduce conflicts.
+state 413 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(#' commas . '#)'
@@ -226,22 +253,35 @@ state 402 contains 1 shift/reduce conflicts.
 
     Conflict: '#)' (empty tup_tail reduces)
 
-Same as State 324 for unboxed tuples.
+Same as State 357 for unboxed tuples.
+
+-------------------------------------------------------------------------------
+
+state 424 contains 67 shift/reduce conflicts.
+
+    *** exp10 -> '-' fexp .
+        fexp -> fexp . aexp
+        fexp -> fexp . TYPEAPP atype
+
+Same as 147 but with a unary minus.
 
 -------------------------------------------------------------------------------
 
-state 477 contains 1 shift/reduce conflict.
+state 488 contains 1 shift/reduce conflict.
 
         oqtycon -> '(' qtyconsym . ')'
     *** qtyconop -> qtyconsym .
 
     Conflict: ')'
 
-TODO: Why?
+Example ambiguity: 'foo :: (:%)'
+
+Shift means '(:%)' gets parsed as a type constructor, rather than than a
+parenthesized infix type expression of length 1.
 
 -------------------------------------------------------------------------------
 
-state 658 contains 1 shift/reduce conflicts.
+state 689 contains 1 shift/reduce conflicts.
 
     *** aexp2 -> ipvar .
         dbind -> ipvar . '=' exp
@@ -256,7 +296,7 @@ sensible meaning, namely the lhs of an implicit binding.
 
 -------------------------------------------------------------------------------
 
-state 731 contains 1 shift/reduce conflicts.
+state 765 contains 1 shift/reduce conflicts.
 
         rule -> STRING rule_activation . rule_forall infixexp '=' exp
 
@@ -273,7 +313,7 @@ doesn't include 'forall'.
 
 -------------------------------------------------------------------------------
 
-state 963 contains 1 shift/reduce conflicts.
+state 1013 contains 1 shift/reduce conflicts.
 
         transformqual -> 'then' 'group' . 'using' exp
         transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -283,14 +323,25 @@ state 963 contains 1 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 1303 contains 1 shift/reduce conflict.
+state 1390 contains 1 shift/reduce conflict.
 
     *** atype -> tyvar .
         tv_bndr -> '(' tyvar . '::' kind ')'
 
     Conflict: '::'
 
-TODO: Why?
+Example ambiguity: 'class C a where type D a = ( a :: * ...'
+
+Here the parser cannot tell whether this is specifying a default for the
+associated type like:
+
+'class C a where type D a = ( a :: * ); type D a'
+
+or it is an injectivity signature like:
+
+'class C a where type D a = ( r :: * ) | r -> a'
+
+Shift means the parser only allows the latter.
 
 -------------------------------------------------------------------------------
 -- API Annotations
@@ -2394,59 +2445,16 @@ infixexp_top :: { LHsExpr GhcPs }
                                   {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
                                          [mj AnnVal $2] }
 
-exp10_top :: { LHsExpr GhcPs }
-        : '\\' apat apats '->' exp
-                   {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
-                            [sLL $1 $> $ Match { m_ctxt = LambdaExpr
-                                               , m_pats = $2:$3
-                                               , m_grhss = unguardedGRHSs $5 }]))
-                          [mj AnnLam $1, mu AnnRarrow $4] }
 
-        | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
-                                               (mj AnnLet $1:mj AnnIn $3
-                                                 :(fst $ unLoc $2)) }
-        | '\\' 'lcase' altslist
-            {% ams (sLL $1 $> $ HsLamCase
-                                   (mkMatchGroup FromSource (snd $ unLoc $3)))
-                   (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
-        | 'if' exp optSemi 'then' exp optSemi 'else' exp
-                           {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
-                              ams (sLL $1 $> $ mkHsIf $2 $5 $8)
-                                  (mj AnnIf $1:mj AnnThen $4
-                                     :mj AnnElse $7
-                                     :(map (\l -> mj AnnSemi l) (fst $3))
-                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }
-        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
-                                           ams (sLL $1 $> $ HsMultiIf
-                                                     placeHolderType
-                                                     (reverse $ snd $ unLoc $2))
-                                               (mj AnnIf $1:(fst $ unLoc $2)) }
-        | 'case' exp 'of' altslist      {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup
-                                                   FromSource (snd $ unLoc $4)))
-                                               (mj AnnCase $1:mj AnnOf $3
-                                                  :(fst $ unLoc $4)) }
-        | '-' fexp                      {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)
+exp10_top :: { LHsExpr GhcPs }
+        : '-' fexp                      {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)
                                                [mj AnnMinus $1] }
 
-        | 'do' stmtlist              {% ams (L (comb2 $1 $2)
-                                               (mkHsDo DoExpr (snd $ unLoc $2)))
-                                               (mj AnnDo $1:(fst $ unLoc $2)) }
-        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)
-                                              (mkHsDo MDoExpr (snd $ unLoc $2)))
-                                           (mj AnnMdo $1:(fst $ unLoc $2)) }
 
         | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)
                                                                 (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
                                       (fst $ fst $ fst $ unLoc $1) }
 
-        | 'proc' aexp '->' exp
-                       {% checkPattern empty $2 >>= \ p ->
-                           checkCommand $4 >>= \ cmd ->
-                           ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
-                                                placeHolderType []))
-                                            -- TODO: is LL right here?
-                               [mj AnnProc $1,mu AnnRarrow $3] }
-
         | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
                                               [mo $1,mj AnnVal $2
                                               ,mc $3] }
@@ -2498,8 +2506,10 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
                                          }
 
 fexp    :: { LHsExpr GhcPs }
-        : fexp aexp                  { sLL $1 $> $ HsApp $1 $2 }
-        | fexp TYPEAPP atype         {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
+        : fexp aexp                  {% checkBlockArguments $1 >> checkBlockArguments $2 >>
+                                        return (sLL $1 $> $ (HsApp $1 $2)) }
+        | fexp TYPEAPP atype         {% checkBlockArguments $1 >>
+                                        ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
                                             [mj AnnAt $2] }
         | 'static' aexp              {% ams (sLL $1 $> $ HsStatic placeHolderNames $2)
                                             [mj AnnStatic $1] }
@@ -2511,6 +2521,50 @@ aexp    :: { LHsExpr GhcPs }
             -- Note [Lexing type applications] in Lexer.x
 
         | '~' aexp              {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
+
+        | '\\' apat apats '->' exp
+                   {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
+                            [sLL $1 $> $ Match { m_ctxt = LambdaExpr
+                                               , m_pats = $2:$3
+                                               , m_grhss = unguardedGRHSs $5 }]))
+                          [mj AnnLam $1, mu AnnRarrow $4] }
+        | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
+                                               (mj AnnLet $1:mj AnnIn $3
+                                                 :(fst $ unLoc $2)) }
+        | '\\' 'lcase' altslist
+            {% ams (sLL $1 $> $ HsLamCase
+                                   (mkMatchGroup FromSource (snd $ unLoc $3)))
+                   (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
+        | 'if' exp optSemi 'then' exp optSemi 'else' exp
+                           {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
+                              ams (sLL $1 $> $ mkHsIf $2 $5 $8)
+                                  (mj AnnIf $1:mj AnnThen $4
+                                     :mj AnnElse $7
+                                     :(map (\l -> mj AnnSemi l) (fst $3))
+                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }
+        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
+                                           ams (sLL $1 $> $ HsMultiIf
+                                                     placeHolderType
+                                                     (reverse $ snd $ unLoc $2))
+                                               (mj AnnIf $1:(fst $ unLoc $2)) }
+        | 'case' exp 'of' altslist      {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup
+                                                   FromSource (snd $ unLoc $4)))
+                                               (mj AnnCase $1:mj AnnOf $3
+                                                  :(fst $ unLoc $4)) }
+        | 'do' stmtlist              {% ams (L (comb2 $1 $2)
+                                               (mkHsDo DoExpr (snd $ unLoc $2)))
+                                               (mj AnnDo $1:(fst $ unLoc $2)) }
+        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)
+                                              (mkHsDo MDoExpr (snd $ unLoc $2)))
+                                           (mj AnnMdo $1:(fst $ unLoc $2)) }
+        | 'proc' aexp '->' exp
+                       {% checkPattern empty $2 >>= \ p ->
+                           checkCommand $4 >>= \ cmd ->
+                           ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
+                                                placeHolderType []))
+                                            -- TODO: is LL right here?
+                               [mj AnnProc $1,mu AnnRarrow $3] }
+
         | aexp1                 { $1 }
 
 aexp1   :: { LHsExpr GhcPs }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 389e7ee782..fcb1fede20 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -42,6 +42,7 @@ module   RdrHsSyn (
 
         -- Bunch of functions in the parser monad for
         -- checking and constructing values
+        checkBlockArguments,
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
         checkInfixConstr,
@@ -825,6 +826,29 @@ checkTyClHdr is_cls ty
       = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                           <+> ppr ty)
 
+-- | Yield a parse error if we have a function applied directly to a do block
+-- etc. and BlockArguments is not enabled.
+checkBlockArguments :: LHsExpr GhcPs -> P ()
+checkBlockArguments expr = case unLoc expr of
+    HsDo DoExpr _ _ -> check "do block"
+    HsDo MDoExpr _ _ -> check "mdo block"
+    HsLam {} -> check "lambda expression"
+    HsCase {} -> check "case expression"
+    HsLamCase {} -> check "lambda-case expression"
+    HsLet {} -> check "let expression"
+    HsIf {} -> check "if expression"
+    HsProc {} -> check "proc expression"
+    _ -> return ()
+  where
+    check element = do
+      pState <- getPState
+      unless (extopt LangExt.BlockArguments (options pState)) $
+        parseErrorSDoc (getLoc expr) $
+          text "Unexpected " <> text element <> text " in function application:"
+           $$ nest 4 (ppr expr)
+           $$ text "You could write it with parentheses"
+           $$ text "Or perhaps you meant to enable BlockArguments?"
+
 checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
 checkContext (L l orig_t)
   = check [] (L l orig_t)