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

22 files changed, 355 insertions, 85 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)
diff --git a/docs/users_guide/bugs.rst b/docs/users_guide/bugs.rst
index 7d41d874bb..3cfc023ea0 100644
--- a/docs/users_guide/bugs.rst
+++ b/docs/users_guide/bugs.rst
@@ -83,12 +83,6 @@ Context-free syntax
 
            (let x = 42 in x == 42 == True)
 
--  The Haskell Report allows you to put a unary ``-`` preceding certain
-   expressions headed by keywords, allowing constructs like ``- case x of ...``
-   or ``- do { ... }``. GHC does not allow this. Instead, unary ``-`` is allowed
-   before only expressions that could potentially be applied as a function.
-
-
 .. _infelicities-exprs-pats:
 
 Expressions and patterns
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 514dae8dd6..190c611ede 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -2098,6 +2098,104 @@ data constructor in an import or export list with the keyword
 ``pattern``, to allow the import or export of a data constructor without
 its parent type constructor (see :ref:`patsyn-impexp`).
 
+.. _block-arguments:
+
+More liberal syntax for function arguments
+------------------------------------------
+
+.. extension:: BlockArguments
+    :shortdesc: Allow ``do`` blocks and other constructs as function arguments.
+
+    :since: 8.6.1
+
+    Allow ``do`` expressions, lambda expressions, etc. to be directly used as
+    a function argument.
+
+In Haskell 2010, certain kinds of expressions can be used without parentheses
+as an argument to an operator, but not as an argument to a function.
+They include ``do``, lambda, ``if``, ``case``, and ``let``
+expressions. Some GHC extensions also define language constructs of this type:
+``mdo`` (:ref:`recursive-do-notation`), ``\case`` (:ref:`lambda-case`), and
+``proc`` (:ref:`arrow-notation`).
+
+The :extension:`BlockArguments` extension allows these constructs to be directly
+used as a function argument. For example::
+
+    when (x > 0) do
+      print x
+      exitFailure
+
+will be parsed as::
+
+    when (x > 0) (do
+      print x
+      exitFailure)
+
+and
+
+::
+
+    withForeignPtr fptr \ptr -> c_memcpy buf ptr size
+
+will be parsed as::
+
+    withForeignPtr fptr (\ptr -> c_memcpy buf ptr size)
+
+Changes to the grammar
+~~~~~~~~~~~~~~~~~~~~~~
+
+The Haskell report `defines
+<https://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-220003>`_
+the ``lexp`` nonterminal thus (``*`` indicates a rule of interest)::
+
+    lexp  →  \ apat1 … apatn -> exp            (lambda abstraction, n ≥ 1)  *
+          |  let decls in exp                  (let expression)             *
+          |  if exp [;] then exp [;] else exp  (conditional)                *
+          |  case exp of { alts }              (case expression)            *
+          |  do { stmts }                      (do expression)              *
+          |  fexp
+
+    fexp  →  [fexp] aexp                       (function application)
+
+    aexp  →  qvar                              (variable)
+          |  gcon                              (general constructor)
+          |  literal
+          |  ( exp )                           (parenthesized expression)
+          |  qcon { fbind1 … fbindn }          (labeled construction)
+          |  aexp { fbind1 … fbindn }          (labelled update)
+          |  …
+
+The :extension:`BlockArguments` extension moves these production rules under
+``aexp``::
+
+    lexp  →  fexp
+
+    fexp  →  [fexp] aexp                       (function application)
+
+    aexp  →  qvar                              (variable)
+          |  gcon                              (general constructor)
+          |  literal
+          |  ( exp )                           (parenthesized expression)
+          |  qcon { fbind1 … fbindn }          (labeled construction)
+          |  aexp { fbind1 … fbindn }          (labelled update)
+          |  \ apat1 … apatn -> exp            (lambda abstraction, n ≥ 1)  *
+          |  let decls in exp                  (let expression)             *
+          |  if exp [;] then exp [;] else exp  (conditional)                *
+          |  case exp of { alts }              (case expression)            *
+          |  do { stmts }                      (do expression)              *
+          |  …
+
+Now the ``lexp`` nonterminal is redundant and can be dropped from the grammar.
+
+Note that this change relies on an existing meta-rule to resolve ambiguities:
+
+    The grammar is ambiguous regarding the extent of lambda abstractions, let
+    expressions, and conditionals. The ambiguity is resolved by the meta-rule
+    that each of these constructs extends as far to the right as possible.
+
+For example, ``f \a -> a b`` will be parsed as ``f (\a -> a b)``, not as ``f
+(\a -> a) b``.
+
 .. _syntax-stolen:
 
 Summary of stolen syntax
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index 2b06c851a8..b3016e167d 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -63,6 +63,7 @@ data Extension
    | GADTSyntax
    | NPlusKPatterns
    | DoAndIfThenElse
+   | BlockArguments
    | RebindableSyntax
    | ConstraintKinds
    | PolyKinds                -- Kind polymorphism
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 6a46e52ad6..14d9bf4b1d 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -40,6 +40,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
                              "EmptyDataDeriving",
+                             "BlockArguments",
                              "NumericUnderscores"]
 
 expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/parser/should_compile/BlockArguments.hs b/testsuite/tests/parser/should_compile/BlockArguments.hs
new file mode 100644
index 0000000000..f74c09d97c
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/BlockArguments.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE BlockArguments #-}
+
+module BlockArguments where
+
+import Control.Monad
+
+foo :: IO ()
+foo = when True do
+  return ()
+
+foo' :: IO ()
+foo' = do
+  forM [1 .. 10] \x ->
+    print x
+
+  forM [1 .. 10] \x -> do
+    print x
+    print x
+
+  return ()
+
+foo'' :: IO ()
+foo'' = when
+  do True
+  do return ()
diff --git a/testsuite/tests/parser/should_compile/BlockArgumentsLambdaCase.hs b/testsuite/tests/parser/should_compile/BlockArgumentsLambdaCase.hs
new file mode 100644
index 0000000000..8e336c28f4
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/BlockArgumentsLambdaCase.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE BlockArguments, LambdaCase #-}
+
+module BlockArgumentsLambdaCase where
+
+import Control.Monad
+
+foo' :: IO ()
+foo' = do
+  forM [Just 3, Nothing] \case
+    Just 3 -> print 3
+    _ -> print 5
+
+  return ()
diff --git a/testsuite/tests/parser/should_compile/NoBlockArguments.hs b/testsuite/tests/parser/should_compile/NoBlockArguments.hs
new file mode 100644
index 0000000000..169a460203
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/NoBlockArguments.hs
@@ -0,0 +1,8 @@
+module NoBlockArguments where
+
+-- Make sure things parse normally
+f  :: a -> a
+f = id
+
+foo :: [Int]
+foo = f [x | x <- [1 .. 10]]
diff --git a/testsuite/tests/parser/should_compile/T10855.hs b/testsuite/tests/parser/should_compile/T10855.hs
new file mode 100644
index 0000000000..cc66f5d4b3
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T10855.hs
@@ -0,0 +1,5 @@
+module T10855 where
+
+bool :: Int
+bool = - case 3 > 5 of False -> 0; True -> (-1)
+main = print (- do 4)
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index e2f68f6e96..cc9771087f 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -85,6 +85,9 @@ test('T2245', normal, compile, ['-fwarn-type-defaults'])
 test('T3303', [], multimod_compile, ['T3303', '-v0'])
 test('T3741', normal, compile, [''])
 test('DoAndIfThenElse', normal, compile, [''])
+test('BlockArguments', normal, compile, [''])
+test('BlockArgumentsLambdaCase', normal, compile, [''])
+test('NoBlockArguments', normal, compile, [''])
 test('NondecreasingIndentation', normal, compile, [''])
 test('mc15', normal, compile, [''])
 test('mc16', normal, compile, [''])
@@ -110,3 +113,4 @@ test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast']
 test('T13747', normal, compile, [''])
 test('T14189',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('T13986', normal, compile, [''])
+test('T10855', normal, compile, [''])
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.hs b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.hs
new file mode 100644
index 0000000000..6c791b0f95
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.hs
@@ -0,0 +1,7 @@
+module NoBlockArgumentsFail where
+
+import Control.Monad
+
+foo :: IO ()
+foo = when True do
+  return ()
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr
new file mode 100644
index 0000000000..813271bdb9
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr
@@ -0,0 +1,6 @@
+
+NoBlockArgumentsFail.hs:6:17: error:
+    Unexpected do block in function application:
+        do return ()
+    You could write it with parentheses
+    Or perhaps you meant to enable BlockArguments?
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.hs b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.hs
new file mode 100644
index 0000000000..752df24081
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.hs
@@ -0,0 +1,6 @@
+module NoBlockArgumentsFail2 where
+
+import Control.Monad
+
+foo :: IO ()
+foo = forM [1 .. 10] \x -> print x
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr
new file mode 100644
index 0000000000..0361369774
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr
@@ -0,0 +1,6 @@
+
+NoBlockArgumentsFail2.hs:6:22: error:
+    Unexpected lambda expression in function application:
+        \ x -> print x
+    You could write it with parentheses
+    Or perhaps you meant to enable BlockArguments?
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.hs b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.hs
new file mode 100644
index 0000000000..91bd6e5dec
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE LambdaCase #-}
+module NoBlockArgumentsFail3 where
+
+import Control.Monad
+
+foo :: IO ()
+foo = forM [1 .. 10] \case
+  Just 3 -> print x
diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr
new file mode 100644
index 0000000000..e285e6ea72
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr
@@ -0,0 +1,6 @@
+
+NoBlockArgumentsFail3.hs:7:22: error:
+    Unexpected lambda-case expression in function application:
+        \case Just 3 -> print x
+    You could write it with parentheses
+    Or perhaps you meant to enable BlockArguments?
diff --git a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
index 5eb8b539a3..24d5cfc168 100644
--- a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
+++ b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
@@ -1,2 +1,2 @@
-
-ParserNoLambdaCase.hs:3:6: error: parse error on input ‘case’
+ParserNoLambdaCase.hs:3:6:
+    Illegal lambda-case (use -XLambdaCase)
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index c16a988c2f..6f6331ff06 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -69,6 +69,9 @@ test('T3811f', normal, compile_fail, [''])
 test('T3811g', normal, compile_fail, [''])
 test('NoDoAndIfThenElse', normal, compile_fail, [''])
 test('NoPatternSynonyms', normal, compile_fail, [''])
+test('NoBlockArgumentsFail', normal, compile_fail, [''])
+test('NoBlockArgumentsFail2', normal, compile_fail, [''])
+test('NoBlockArgumentsFail3', normal, compile_fail, [''])
 test('NondecreasingIndentationFail', normal, compile_fail, [''])
 test('readFailTraditionalRecords1', normal, compile_fail, [''])
 test('readFailTraditionalRecords2', normal, compile_fail, [''])
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 257d9b0b83..84bfd75bb4 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -474,11 +474,12 @@ test('parsing001',
           [(wordsize(32), 232777056, 10),
         # Initial:        274000576
         # 2017-03-24:     232777056
-           (wordsize(64), 463931280, 5)]),
+           (wordsize(64), 490228304, 5)]),
         # expected value: 587079016 (amd64/Linux)
         # 2016-09-01:     581551384 (amd64/Linux) Restore w/w limit (#11565)
         # 2016-12-19:     493730288 (amd64/Linux) Join points (#12988)
         # 2017-02-14:     463931280 Early inlining patch; acutal improvement 7%
+        # 2017-12-11:     490228304 BlockArguments
        only_ways(['normal']),
       ],
      compile_fail, [''])