Deal with unbreakable blocks in Applicative Do

The renamer wasn't able to deal with more than a couple strict
patterns in a row with `ApplicativeDo` when using the heuristic
splitter. Update it to work with them properly.

Reviewers: simonmar, austin, bgamari, hvr

Reviewed By: simonmar

Subscribers: RyanGlScott, lippling, rwbarton, thomie

GHC Trac Issues: #14163

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

5 files changed, 23 insertions, 2 deletions

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 477a448332..5ccefb8467 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1821,9 +1821,12 @@ slurpIndependentStmts
 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
  where
   -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
-  -- in this group, then add it to the group.
+  -- in this group, then add it to the group. We have to be careful about
+  -- strict patterns though; splitSegments expects that if we return Just
+  -- then we have actually done some splitting. Otherwise it will go into
+  -- an infinite loop (#14163).
   go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
-    | isEmptyNameSet (bndrs `intersectNameSet` fvs)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
     = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
          bndrs' rest
     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
diff --git a/testsuite/tests/ado/T14163.hs b/testsuite/tests/ado/T14163.hs
new file mode 100644
index 0000000000..9463c1c5fc
--- /dev/null
+++ b/testsuite/tests/ado/T14163.hs
@@ -0,0 +1,13 @@
+{-# language ApplicativeDo #-}
+
+import GHC.Exts
+
+readIt :: IO (Int, Int)
+readIt = readLn
+
+main :: IO ()
+main = do
+  (_, _) <- readIt
+  (_, _) <- readIt
+  (_, _) <- readIt
+  print "Done"
diff --git a/testsuite/tests/ado/T14163.stdin b/testsuite/tests/ado/T14163.stdin
new file mode 100644
index 0000000000..0f620463b5
--- /dev/null
+++ b/testsuite/tests/ado/T14163.stdin
@@ -0,0 +1,3 @@
+(1,2)
+(3,4)
+(5,6)
diff --git a/testsuite/tests/ado/T14163.stdout b/testsuite/tests/ado/T14163.stdout
new file mode 100644
index 0000000000..5a32621be4
--- /dev/null
+++ b/testsuite/tests/ado/T14163.stdout
@@ -0,0 +1 @@
+"Done"
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index bb1cc163d1..d88e907315 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -11,3 +11,4 @@ test('T12490', normal, compile, [''])
 test('T13242', normal, compile, [''])
 test('T13242a', normal, compile_fail, [''])
 test('T13875', normal, compile_and_run, [''])
+test('T14163', normal, compile_and_run, [''])