Commit 011e15aa authored by David Feuer's avatar David Feuer Committed by David Feuer

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
parent cb4878ff
...@@ -1821,9 +1821,12 @@ slurpIndependentStmts ...@@ -1821,9 +1821,12 @@ slurpIndependentStmts
slurpIndependentStmts stmts = go [] [] emptyNameSet stmts slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
where where
-- If we encounter a BindStmt that doesn't depend on a previous BindStmt -- 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) 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) = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
bndrs' rest bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
......
{-# language ApplicativeDo #-}
import GHC.Exts
readIt :: IO (Int, Int)
readIt = readLn
main :: IO ()
main = do
(_, _) <- readIt
(_, _) <- readIt
(_, _) <- readIt
print "Done"
...@@ -11,3 +11,4 @@ test('T12490', normal, compile, ['']) ...@@ -11,3 +11,4 @@ test('T12490', normal, compile, [''])
test('T13242', normal, compile, ['']) test('T13242', normal, compile, [''])
test('T13242a', normal, compile_fail, ['']) test('T13242a', normal, compile_fail, [''])
test('T13875', normal, compile_and_run, ['']) test('T13875', normal, compile_and_run, [''])
test('T14163', normal, compile_and_run, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment