Fix for recover with -fexternal-interpreter (#15418)

Summary:
When using -fexternal-interpreter, recover was not treating a Q
compuation that simply registered an error with addErrTc as failing.

Test Plan:
New unit tests:
* T15418 is the repro from in the ticket
* TH_recover_warns is a new test to ensure that we're keeping warnings when
  the body of recover succeeds.

Reviewers: bgamari, RyanGlScott, angerman, goldfire, erikd

Subscribers: rwbarton, carter

GHC Trac Issues: #15418

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

5 files changed, 45 insertions, 0 deletions

diff --git a/testsuite/tests/th/T15481.hs b/testsuite/tests/th/T15481.hs
new file mode 100644
index 0000000000..0d9931d0df
--- /dev/null
+++ b/testsuite/tests/th/T15481.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bug where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = putStrLn $(recover (stringE "reifyFixity failed")
+                          (do foo <- newName "foo"
+                              _ <- reifyFixity foo
+                              stringE "reifyFixity successful"))
diff --git a/testsuite/tests/th/T15481.stderr b/testsuite/tests/th/T15481.stderr
new file mode 100644
index 0000000000..69a8c7b0e7
--- /dev/null
+++ b/testsuite/tests/th/T15481.stderr
@@ -0,0 +1,8 @@
+T15481.hs:(7,19)-(10,63): Splicing expression
+    recover
+      (stringE "reifyFixity failed")
+      (do foo <- newName "foo"
+          _ <- reifyFixity foo
+          stringE "reifyFixity successful")
+  ======>
+    "reifyFixity failed"
diff --git a/testsuite/tests/th/TH_recover_warns.hs b/testsuite/tests/th/TH_recover_warns.hs
new file mode 100644
index 0000000000..9d1153930e
--- /dev/null
+++ b/testsuite/tests/th/TH_recover_warns.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+module Bug where
+
+import Language.Haskell.TH
+
+-- Warnings should be preserved through recover
+main :: IO ()
+main = putStrLn $(recover (stringE "splice failed")
+                          [| let x = "a" in let x = "b" in x |])
diff --git a/testsuite/tests/th/TH_recover_warns.stderr b/testsuite/tests/th/TH_recover_warns.stderr
new file mode 100644
index 0000000000..c92ee71bc9
--- /dev/null
+++ b/testsuite/tests/th/TH_recover_warns.stderr
@@ -0,0 +1,15 @@
+TH_recover_warns.hs:(9,19)-(10,63): Splicing expression
+    recover
+      (stringE "splice failed") [| let x = "a" in let x = "b" in x |]
+  ======>
+    let x = "a" in let x = "b" in x
+
+TH_recover_warns.hs:9:19: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)]
+    Defined but not used: ‘x’
+
+TH_recover_warns.hs:10:34: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)]
+    Defined but not used: ‘x’
+
+TH_recover_warns.hs:10:49: warning: [-Wname-shadowing (in -Wall)]
+    This binding for ‘x’ shadows the existing binding
+      bound at TH_recover_warns.hs:10:34
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 9a25591937..948c7db8d7 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -434,3 +434,5 @@ test('TH_implicitParamsErr1', normal, compile_fail, ['-v0 -dsuppress-uniques'])
 test('TH_implicitParamsErr2', normal, compile_fail, ['-v0 -dsuppress-uniques'])
 test('TH_implicitParamsErr3', normal, compile_fail, ['-v0 -dsuppress-uniques'])
 test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
+test('T15481', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_recover_warns', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])