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

2 files changed, 17 insertions, 13 deletions

diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 012dd884ba..bc0a19ca62 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -259,6 +259,7 @@ data THMessage a where
 
   StartRecover :: THMessage ()
   EndRecover :: Bool -> THMessage ()
+  FailIfErrs :: THMessage (THResult ())
 
   -- | Indicates that this RunTH is finished, and the next message
   -- will be the result of RunTH (a QResult).
@@ -289,9 +290,10 @@ getTHMessage = do
     14 -> THMsg <$> return ExtsEnabled
     15 -> THMsg <$> return StartRecover
     16 -> THMsg <$> EndRecover <$> get
-    17 -> return (THMsg RunTHDone)
-    18 -> THMsg <$> AddModFinalizer <$> get
-    19 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
+    17 -> THMsg <$> return FailIfErrs
+    18 -> return (THMsg RunTHDone)
+    19 -> THMsg <$> AddModFinalizer <$> get
+    20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
     _  -> THMsg <$> AddCorePlugin <$> get
 
 putTHMessage :: THMessage a -> Put
@@ -313,10 +315,11 @@ putTHMessage m = case m of
   ExtsEnabled                 -> putWord8 14
   StartRecover                -> putWord8 15
   EndRecover a                -> putWord8 16 >> put a
-  RunTHDone                   -> putWord8 17
-  AddModFinalizer a           -> putWord8 18 >> put a
-  AddForeignFilePath lang a   -> putWord8 19 >> put lang >> put a
-  AddCorePlugin a             -> putWord8 20 >> put a
+  FailIfErrs                  -> putWord8 17
+  RunTHDone                   -> putWord8 18
+  AddModFinalizer a           -> putWord8 19 >> put a
+  AddForeignFilePath lang a   -> putWord8 20 >> put lang >> put a
+  AddCorePlugin a             -> putWord8 21 >> put a
 
 
 data EvalOpts = EvalOpts
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 5779b5073e..04c5fcffcc 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -106,6 +106,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Data
 import Data.Dynamic
+import Data.Either
 import Data.IORef
 import Data.Map (Map)
 import qualified Data.Map as M
@@ -170,13 +171,13 @@ instance TH.Quasi GHCiQ where
   qReport isError msg = ghcCmd (Report isError msg)
 
   -- See Note [TH recover with -fexternal-interpreter] in TcSplice
-  qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do
+  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
     remoteTHCall (qsPipe s) StartRecover
-    (r, s') <- a s
-    remoteTHCall (qsPipe s) (EndRecover False)
-    return (r,s'))
-      `catch`
-       \GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s
+    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
+    remoteTHCall (qsPipe s) (EndRecover (isLeft e))
+    case e of
+      Left GHCiQException{} -> h s
+      Right r -> return r
   qLookupName isType occ = ghcCmd (LookupName isType occ)
   qReify name = ghcCmd (Reify name)
   qReifyFixity name = ghcCmd (ReifyFixity name)