Fix for recover with -fexternal-interpreter (#15418)
[ghc.git] / libraries / ghci / GHCi / TH.hs
index 1b08501..04c5fcf 100644 (file)
@@ -91,12 +91,14 @@ Other Notes on TH / Remote GHCi
     compiler/typecheck/TcSplice.hs
 -}
 
+import Prelude -- See note [Why do we import Prelude here?]
 import GHCi.Message
 import GHCi.RemoteTypes
 import GHC.Serialized
 
 import Control.Exception
 import qualified Control.Monad.Fail as Fail
+import Control.Monad.IO.Class (MonadIO (..))
 import Data.Binary
 import Data.Binary.Put
 import Data.ByteString (ByteString)
@@ -104,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
@@ -160,18 +163,21 @@ ghcCmd m = GHCiQ $ \s -> do
     THException str -> throwIO (GHCiQException s str)
     THComplete res -> return (res, s)
 
+instance MonadIO GHCiQ where
+  liftIO m = GHCiQ $ \s -> fmap (,s) m
+
 instance TH.Quasi GHCiQ where
   qNewName str = ghcCmd (NewName str)
   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)
@@ -190,12 +196,13 @@ instance TH.Quasi GHCiQ where
   qReifyModule m = ghcCmd (ReifyModule m)
   qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
   qLocation = fromMaybe noLoc . qsLocation <$> getState
-  qRunIO m = GHCiQ $ \s -> fmap (,s) m
   qAddDependentFile file = ghcCmd (AddDependentFile file)
+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
-  qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
   qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
                          ghcCmd . AddModFinalizer
+  qAddCorePlugin str = ghcCmd (AddCorePlugin str)
   qGetQ = GHCiQ $ \s ->
     let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
         lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m