Fix handling of ApplicativeDo in TH AST quotes

See https://ghc.haskell.org/trac/ghc/ticket/14471

Also fixes a parenthesization bug in pprStmt when ret_stripped is True

Test Plan: tests added to testsuite

Trac issues: #14471

Reviewers: goldfire, bgamari

Reviewed By: goldfire

Subscribers: rwbarton, thomie, carter

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

6 files changed, 43 insertions, 1 deletions

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 937ffaf248..b9e097c4d8 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -26,6 +26,7 @@ import GhcPrelude
 import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
                    rnMatchGroup, rnGRHS, makeMiniFixityEnv)
 import HsSyn
+import TcEnv            ( isBrackStage )
 import TcRnMonad
 import Module           ( getModule )
 import RnEnv
@@ -731,7 +732,10 @@ postProcessStmtsForApplicativeDo ctxt stmts
          ado_is_on <- xoptM LangExt.ApplicativeDo
        ; let is_do_expr | DoExpr <- ctxt = True
                         | otherwise = False
-       ; if ado_is_on && is_do_expr
+       -- don't apply the transformation inside TH brackets, because
+       -- DsMeta does not handle ApplicativeDo.
+       ; in_th_bracket <- isBrackStage <$> getStage
+       ; if ado_is_on && is_do_expr && not in_th_bracket
             then do { traceRn "ppsfa" (ppr stmts)
                     ; rearrangeForApplicativeDo ctxt stmts }
             else noPostProcessStmts ctxt stmts }
diff --git a/testsuite/tests/th/T14471.hs b/testsuite/tests/th/T14471.hs
new file mode 100644
index 0000000000..e1355b1ae5
--- /dev/null
+++ b/testsuite/tests/th/T14471.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import Language.Haskell.TH
+import Prelude
+
+main = putStrLn $(do
+  expr <- [|
+    do x <- getLine
+       y <- getLine
+       pure (x, y)
+    |]
+  stringE (pprint expr))
diff --git a/testsuite/tests/th/T14471.stdout b/testsuite/tests/th/T14471.stdout
new file mode 100644
index 0000000000..f9f15f9e2d
--- /dev/null
+++ b/testsuite/tests/th/T14471.stdout
@@ -0,0 +1,3 @@
+do {x_0 <- System.IO.getLine;
+    y_1 <- System.IO.getLine;
+    GHC.Base.return (x_0, y_1)}
diff --git a/testsuite/tests/th/TH_rebindableAdo.hs b/testsuite/tests/th/TH_rebindableAdo.hs
new file mode 100644
index 0000000000..ad97020e70
--- /dev/null
+++ b/testsuite/tests/th/TH_rebindableAdo.hs
@@ -0,0 +1,17 @@
+-- Same as T14471 but also enables RebindableSyntax, since that's a
+-- tricky case.
+
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import Language.Haskell.TH
+import Prelude
+
+main = putStrLn $(do
+  expr <- [|
+    do x <- getLine
+       y <- getLine
+       pure (x, y)
+    |]
+  stringE (pprint expr))
diff --git a/testsuite/tests/th/TH_rebindableAdo.stdout b/testsuite/tests/th/TH_rebindableAdo.stdout
new file mode 100644
index 0000000000..4fc2806dc0
--- /dev/null
+++ b/testsuite/tests/th/TH_rebindableAdo.stdout
@@ -0,0 +1,3 @@
+do {x_0 <- System.IO.getLine;
+    y_1 <- System.IO.getLine;
+    GHC.Base.pure (x_0, y_1)}
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index e147491d7c..d55d4150cb 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -420,3 +420,5 @@ test('T15324', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15331', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 # Note: T9693 should be only_ways(['ghci']) once it's fixed.
 test('T9693', expect_broken(9693), ghci_script, ['T9693.script'])
+test('T14471', normal, compile, [''])
+test('TH_rebindableAdo', normal, compile, [''])