diff options
| -rw-r--r-- | compiler/rename/RnExpr.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/th/T14471.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/th/T14471.stdout | 3 | ||||
| -rw-r--r-- | testsuite/tests/th/TH_rebindableAdo.hs | 17 | ||||
| -rw-r--r-- | testsuite/tests/th/TH_rebindableAdo.stdout | 3 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 2 |
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, ['']) |