[commit: ghc] master: Deal with unbreakable blocks in Applicative Do (011e15a)

[git at git.haskell.org]

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

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

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

commit 011e15aa2d6949fc56126f1028ea25d5497196d9
Author: David Feuer <david.feuer at gmail.com>
Date:   Thu Sep 7 23:56:35 2017 -0400

    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


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

011e15aa2d6949fc56126f1028ea25d5497196d9
 compiler/rename/RnExpr.hs         |  7 +++++--
 testsuite/tests/ado/T14163.hs     | 13 +++++++++++++
 testsuite/tests/ado/T14163.stdin  |  3 +++
 testsuite/tests/ado/T14163.stdout |  1 +
 testsuite/tests/ado/all.T         |  1 +
 5 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 477a448..5ccefb8 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 0000000..9463c1c
--- /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 0000000..0f62046
--- /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 0000000..5a32621
--- /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 bb1cc16..d88e907 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, [''])