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

15 files changed, 102 insertions, 3 deletions

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, [''])