Deal with unbreakable blocks in Applicative Do
authorDavid Feuer <david.feuer@gmail.com>
Fri, 8 Sep 2017 03:56:35 +0000 (23:56 -0400)
committerDavid Feuer <David.Feuer@gmail.com>
Fri, 8 Sep 2017 03:56:36 +0000 (23:56 -0400)
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

compiler/rename/RnExpr.hs
testsuite/tests/ado/T14163.hs [new file with mode: 0644]
testsuite/tests/ado/T14163.stdin [new file with mode: 0644]
testsuite/tests/ado/T14163.stdout [new file with mode: 0644]
testsuite/tests/ado/all.T

index 477a448..5ccefb8 100644 (file)
@@ -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 (file)
index 0000000..9463c1c
--- /dev/null
@@ -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 (file)
index 0000000..0f62046
--- /dev/null
@@ -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 (file)
index 0000000..5a32621
--- /dev/null
@@ -0,0 +1 @@
+"Done"
index bb1cc16..d88e907 100644 (file)
@@ -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, [''])