[commit: ghc] master: Fix handling of ApplicativeDo in TH AST quotes (234093c)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/234093cf1562d032b38382a5cc08be8dd71c4fe3/ghc

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

commit 234093cf1562d032b38382a5cc08be8dd71c4fe3
Author: Michael Sloan <mgsloan at gmail.com>
Date:   Thu Jul 12 10:05:41 2018 -0400

    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


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

234093cf1562d032b38382a5cc08be8dd71c4fe3
 compiler/rename/RnExpr.hs                  |  6 +++++-
 testsuite/tests/th/T14471.hs               | 13 +++++++++++++
 testsuite/tests/th/T14471.stdout           |  3 +++
 testsuite/tests/th/TH_rebindableAdo.hs     | 17 +++++++++++++++++
 testsuite/tests/th/TH_rebindableAdo.stdout |  3 +++
 testsuite/tests/th/all.T                   |  2 ++
 6 files changed, 43 insertions(+), 1 deletion(-)

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 937ffaf..b9e097c 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 0000000..e1355b1
--- /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 0000000..f9f15f9
--- /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 0000000..ad97020
--- /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 0000000..4fc2806
--- /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 e147491..d55d415 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, [''])