sendTHComputation

   :: Binary a

   => ExtInterpInstance d

   -> (forall b. Binary b => THMessage b -> IO (Bool, b))

   -- ^ Handle one message. Return True to end the loop.

   -- This handler must never uninterrutibly mask an expression which may get

   -> IO a

 sendTHComputation i msg reqHandler = mask $ \restore -> do

   -- inline "withAsync/wait"

     `onException` uninterruptibleMask_ (throwTo ht CancelTHHandler)

   where

     proc = instProcess i

         (stop, res) <- reqHandler req

         writeIORef doneRef stop

         return res

       doneRef <- newIORef False

       let loop = do

             isDone <- readIORef doneRef

             if isDone then return ()

                       else loop

             recovers <- newIORef []

             withForeignRef fhv $ \st ->

               withForeignRefs finRefs $ \qrefs ->

                   runInIO (runRemoteTH recovers msg)

           checkQResult qr

         recovers <- newIORef []

         withForeignRef rstate $ \state_hv ->

           withForeignRef fhv $ \q_hv ->

               runInIO (runRemoteTH recovers msg)

       bs <- checkQResult qr

       return $! runGet get (LB.fromStrict bs)

   , handleRemoteCall, handleRemoteTHCall

   , RemoteProcessException(..), PipeClosedException(..)

   , BreakModule

   , BreakUnitId

   , LoadedDLL

   -- they did, we have to serialize the value anyway, so we might

   -- as well serialize it to force it.

   RunTH

    -> HValueRef {- e.g. TH.Q TH.Exp -}

    -> THResultType

    -> Maybe TH.Loc

    -> Message (QResult ByteString)

   -- | Run the given mod finalizers.

                    -> [RemoteRef (TH.Q ())]

                    -> Message (QResult ())

 -- StartTH message.  A new one is created per module that GHC

 -- typechecks.

 data QState = QState

        -- ^ persistent data between splices in a module

        -- ^ location for current splice, if any

        -- ^ pipe to communicate with GHC

   }

 instance Show QState where show _ = "<QState>"

       29 -> Msg <$> (BreakpointStatus <$> get <*> get)

       30 -> Msg <$> (GetBreakpointVar <$> get <*> get)

       31 -> Msg <$> return StartTH

       33 -> Msg <$> (AddSptEntry <$> get <*> get)

       35 -> Msg <$> (GetClosure <$> get)

       36 -> Msg <$> (Seq <$> get)

       37 -> Msg <$> return RtsRevertCAFs

   BreakpointStatus arr ix     -> putWord8 29 >> put arr >> put ix

   GetBreakpointVar a b        -> putWord8 30 >> put a >> put b

   StartTH                     -> putWord8 31

   AddSptEntry a b             -> putWord8 33 >> put a >> put b

   GetClosure a                -> putWord8 35 >> put a

   Seq a                       -> putWord8 36 >> put a

   RtsRevertCAFs               -> putWord8 37

 -- (blocks on the calling side, doesn't necessarily block the interpreter)

 remoteCall :: Binary a => Pipe -> Message a -> IO a

 remoteCall pipe msg = either throwIO (pure . runGet get)

 -- | Handle a single 'Message' request on the interpreter and reply to the host

 handleRemoteCall :: Pipe

                  -> (forall a. (Show a, Binary a) => Message a -> IO a)

                  -> IO ()

 handleRemoteCall pipe hook k =

     case hook msg0 |#> s0 of -- unIO for linearity checking

       (# s1, Msg msg #) -> case k msg |#> s1 of

         (# s2, a #) -> writeReply writer (put a) |#> s2

 -- | Send a 'THMessage' request to the host and wait for a reply from the host

 -- | Handle a 'THMessage' request on the host and reply to the interpreter.

 handleRemoteTHCall

     case k msg |#> s0 of -- unIO for linearity checking

       (# s1, a #) -> writeReply writer (put a) |#> s1

 --------------------------------------------------------------------------------

 -- | Send an asynchronous request and block waiting for a matching reply

   let pendingReplies = pendingReply (pipeAsyncMngr pipe)

   -- Mark pending request

   wv <- newEmptyTMVarIO

   isClosed <- atomically $ do

     throwIO PipeClosedException

   -- Write request

     `onException`

       -- the req wasn't done, or no one will be reading the reply:

       -- in either case, drop it from the pending map.

 -- The handler receives as an argument the function to use to reply to the request.

 -- It must be used exactly once (all requests expect a reply, and you can't

 -- reply more than once). Linear types enforce the handler replies in every

   ack <- newEmptyMVar

   -- Block waiting for request

   mbreq <- atomically $ do

     isClosed <- readTVar (pipeIsClosed pipe)

       then return Nothing

   case mbreq of

     Nothing -> throwIO PipeClosedException

     -- TMVar is signaled when the reply arrives. The exception can originate

     -- from the host process, or from the remote one (with 'RemoteProcessException').

   , requestsQueue :: !(TQueue (CorrelationId, LB.ByteString))

   , asyncDrainTid :: !ThreadId

   }

 type CorrelationId = Int

 -- | We have a single type for requests and replies because both the host and

 -- interpreter may send requests *and* replies on the write end *and* on recv

 -- both on the read end.

 --  2. The interpreter sends a NewName TH request on its Interpreter Write End (IWE)

 --  3. The host sends a reply to the TH request on its HWE

 --  4. The interpreter sends the reply to the RunTH request on its IWE

              | Reply   !CorrelationId (Either SerializableException LB.ByteString)

 instance Binary IddMsg where

   get = do

     b <- getWord8

     case b of

       1 -> Reply   <$> get <*> get

       _ -> fail $ "impossible: Binary IddMsg - " ++ show b

 newAsyncManager :: Pipe -> IO AsyncManager

 newAsyncManager pipe = do

   pendingReply  <- newTVarIO IntMap.empty

   -- Fork thread to drain read end.

   -- (cleaned up on 'closePipe')

   let am = AsyncManager{..}

   pure am

               putTMVar wv (bimap (toException . RemoteProcessException) id bs)

         loop

       -- Receive a request and queue it

         loop

       -- EOF on read handle

       Nothing -> do

   am = pipeAsyncMngr p

 --------------------------------------------------------------------------------

 -- * Pipe thread-safe read/write

         CustomMessage tag payload -> handleCustom tag payload

         Shutdown -> writeIORef doneRef True >> reply ()

         -- TODO: These two should probably be done off the main thread

         _other -> run msg >>= reply

     isDone <- readIORef doneRef

   -- THMessage requests, and then finally send RunTHDone followed by a

   -- QResult.  For an overview of how TH works with Remote GHCi, see

   -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.

     when verbose $ trace "wrapRunTH..."

     r <- try io

     when verbose $ trace "wrapRunTH done."

     when verbose $ trace "writing RunTHDone."

     case r of

       Left e

         | Just (GHCiQException _ err) <- fromException e  -> do

 import Unsafe.Coerce

 -- | Create a new instance of 'QState'

 -- | The monad in which we run TH computations on the server

 newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a }

 ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a

 ghcCmd m = GHCiQ $ \sRef -> do

   s <- readIORef sRef

   case r of

     THException str -> throwIO (GHCiQException s str)

     THComplete res -> return res

   -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice

   , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do

       s <- readIORef sRef

       e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef

       case e of

         Left GHCiQException{} ->

           runGHCiQ (runQinGHCiQ h) sRef

 -- a new IORef QState, and return a RemoteRef to it.

 startTH :: IO (RemoteRef (IORef QState))

 startTH = do

   mkRemoteRef r

 -- | Runs the mod finalizers.

 --

 -- The references must be created on the caller process.

                     -> [RemoteRef (TH.Q ())]

                     -> IO ()

   qs <- mapM localRef qrefs

   qstateref <- localRef rstate

   qstate <- readIORef qstateref

   _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate'

   return ()

 -- | The implementation of the 'RunTH' message

 runTH

   :: Pipe

   -> RemoteRef (IORef QState)

       -- ^ The TH state, created by 'startTH'

   -> HValueRef

   -> IO ByteString

       -- ^ Returns an (encoded) result that depends on the THResultType

   hv <- localRef rhv

   case ty of

     THAnnWrapper -> do

       hv <- unsafeCoerce <$> localRef rhv

       case hv :: AnnotationWrapper of

 -- | Run a Q computation.

 runTHQ

   -> IO ByteString

   qstateref <- localRef rstate

   r <- runGHCiQ (runQinGHCiQ ghciq) qstateref

   return $! LB.toStrict (runPut (put r))