Fix handling of ApplicativeDo in TH AST quotes
authorMichael Sloan <mgsloan@gmail.com>
Thu, 12 Jul 2018 14:05:41 +0000 (10:05 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 12 Jul 2018 15:40:18 +0000 (11:40 -0400)
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

compiler/rename/RnExpr.hs
testsuite/tests/th/T14471.hs [new file with mode: 0644]
testsuite/tests/th/T14471.stdout [new file with mode: 0644]
testsuite/tests/th/TH_rebindableAdo.hs [new file with mode: 0644]
testsuite/tests/th/TH_rebindableAdo.stdout [new file with mode: 0644]
testsuite/tests/th/all.T

index 937ffaf..b9e097c 100644 (file)
@@ -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 (file)
index 0000000..e1355b1
--- /dev/null
@@ -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 (file)
index 0000000..f9f15f9
--- /dev/null
@@ -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 (file)
index 0000000..ad97020
--- /dev/null
@@ -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 (file)
index 0000000..4fc2806
--- /dev/null
@@ -0,0 +1,3 @@
+do {x_0 <- System.IO.getLine;
+    y_1 <- System.IO.getLine;
+    GHC.Base.pure (x_0, y_1)}
index e147491..d55d415 100644 (file)
@@ -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, [''])