Fix for recover with -fexternal-interpreter (#15418)
[ghc.git] / libraries / ghci / GHCi / TH.hs
index 3495162..04c5fcf 100644 (file)
@@ -5,7 +5,12 @@
 -- |
 -- Running TH splices
 --
-module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where
+module GHCi.TH
+  ( startTH
+  , runModFinalizerRefs
+  , runTH
+  , GHCiQException(..)
+  ) where
 
 {- Note [Remote Template Haskell]
 
@@ -86,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)
@@ -99,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
@@ -110,14 +118,7 @@ import Unsafe.Coerce
 
 -- | Create a new instance of 'QState'
 initQState :: Pipe -> QState
-initQState p = QState M.empty [] Nothing p
-
-runModFinalizers :: GHCiQ ()
-runModFinalizers = go =<< getState
-  where
-    go s | (f:ff) <- qsFinalizers s = do
-      putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
-    go _ = return ()
+initQState p = QState M.empty Nothing p
 
 -- | The monad in which we run TH computations on the server
 newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
@@ -151,9 +152,6 @@ instance Fail.MonadFail GHCiQ where
 getState :: GHCiQ QState
 getState = GHCiQ $ \s -> return (s,s)
 
-putState :: QState -> GHCiQ ()
-putState s = GHCiQ $ \_ -> return ((),s)
-
 noLoc :: TH.Loc
 noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
 
@@ -165,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)
@@ -195,11 +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)
-  qAddModFinalizer fin = GHCiQ $ \s ->
-    return ((), s { qsFinalizers = fin : qsFinalizers s })
+  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
@@ -216,12 +219,17 @@ startTH = do
   r <- newIORef (initQState (error "startTH: no pipe"))
   mkRemoteRef r
 
--- | The implementation of the 'FinishTH' message.
-finishTH :: Pipe -> RemoteRef (IORef QState) -> IO ()
-finishTH pipe rstate = do
+-- | Runs the mod finalizers.
+--
+-- The references must be created on the caller process.
+runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
+                    -> [RemoteRef (TH.Q ())]
+                    -> IO ()
+runModFinalizerRefs pipe rstate qrefs = do
+  qs <- mapM localRef qrefs
   qstateref <- localRef rstate
   qstate <- readIORef qstateref
-  _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
+  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
   return ()
 
 -- | The implementation of the 'RunTH' message