import Control.Concurrent

 import Control.Monad

 import Control.Monad.IO.Class

 import Data.Binary

 import Data.ByteString (ByteString)

 import qualified Data.ByteString.Short as SBS

 #if defined(HAVE_INTERNAL_INTERPRETER)

   InternalInterp     -> run msg -- Just run it directly

 #endif

     sendMessage inst msg

   ExtJS    i -> withJSInterp i action

   ExtWasm  i -> withWasmInterp i action

   ExtIServ i -> withIServ    i action

 withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a

 withExtInterpStatus ext action = case ext of

                else sendMessage i Shutdown

             -- We asked the server to shutdown, so we will also shutdown any communication.

             closePipe (interpPipe (instProcess i))

             pure InterpPending

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

 import GHC.Runtime.Interpreter.Types

 import GHCi.Message

 import GHC.Utils.Panic

 import GHC.Utils.Exception as Ex

 import Data.Binary

 import Control.Concurrent

 import Data.IORef

 import Control.Concurrent.STM

 sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a

 sendMessage i msg =

   remoteCall (interpPipe proc) msg

   where

     proc = instProcess i

   where

     proc = instProcess i

     handleOne mbox doneRef = do

         (stop, res) <- reqHandler req

         writeIORef doneRef stop

         return res

                       else loop

        in loop

 data CancelTHHandler = CancelTHHandler deriving Show

 instance Exception CancelTHHandler where

   fromException = asyncExceptionFromException

       runQinTcM $ sequence_ qs

 #endif

       tcg <- getGblEnv

       th_state <- readTcRef (tcg_th_remote_state tcg)

       case th_state of

       return r

 #endif

       -- Run it on the server.  For an overview of how TH works with

       -- Remote GHCi, see Note [Remote Template Haskell] in

       -- libraries/ghci/GHCi/TH.hs.

   , Pipe(..), mkPipeFromHandles, mkPipeFromContinuations, closePipe

   , remoteCall, remoteTHCall

   , handleRemoteCall, handleRemoteTHCall, writeReply

   , InboxId(..)

   , newMailbox

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

 handleRemoteCall :: Pipe

                  -> (Msg -> IO Msg) {-^ Msg hook -}

                  -> IO r

 handleRemoteCall pipe hook k =

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

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

 -- to the interpreter.

 -- Symmterically to 'remoteTHCall', we always want to specify the 'InboxId' for

 -- RunTH "reverse requests"

 handleRemoteTHCall

 handleRemoteTHCall pipe ii k =

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

   (

     -- * Pipes

     Pipe(..), mkPipeFromHandles, mkPipeFromContinuations

     -- * Interface for async bidirectional RPC

   , remoteAsyncReq, handleAsyncReq

       unless writeAlreadyClosed

         (throwTo (asyncFillTid pipeAsyncMngr) PipeWriteClosedException)

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

 -- ** Pipe thread-safe read/write

 -- and identify whether they are requests or replies.

 writePipe :: Pipe -> IddMsg -> IO ()

     readTVar pipeWriteClosed >>= \case

       True -> throwSTM PipeWriteClosedException

       False -> pure ()

     writeTQueue (writeQueue pipeAsyncMngr) (msg, var)

 -- | Only the 'drainPipe' thread should read from the pipe directly. Other

 -- functions should wait for the matching reply to be delivered asynchronously.

   -- Write request

   writePipe pipe (Request uq ii (runPut msg))

     `onException`

   -- Block waiting for reply

   atomically (takeTMVar wv)

     `onException`

 -- | Receive a single asynchronous request and send a matching reply

 -- asynchronously (the handler may fork a computation that eventually replies

 -- branch, and if the handler otherwise throws, it is handled by 'handleAsyncReq'.

 --

 -- See Note [Exceptions during serialization] about exceptions the 'Put' argument might raise.

 handleAsyncReq pipe getit mii k = mask $ \restore -> do

   let am = pipeAsyncMngr pipe

   ack <- newEmptyMVar

       Nothing -> tryReadTQueue  $  requestsQueue am

       Just ii -> tryReadTQueue =<< getMailbox am ii

     case taken of

       Nothing  | isClosed  -> pure Nothing -- empty and closed

                | otherwise -> retry -- wait for msg

     Nothing -> throwIO PipeReadClosedException -- can't expect reqs

     Just (uq, bs) -> do

       let reply p = do

             putMVar ack ()

       -- Run the continuation which must reply exactly once with 'writeReply'

       case runGetOrFail getit bs of

         Left (_, _, err) -> do

           reply (Left (toException exc))

           throwIO exc

         Right (_, _, it) ->

             -- If there's an exception before the reply is sent, reply with an error instead.

             `catch` \(e :: SomeException) -> do

                     reply (Left e)

                     throwIO e

 -- | 'handleSyncReq' failed to decode an incoming request payload using the given @'Get' a@

 newtype DecodeAsyncReqException = DecodeAsyncReqException String deriving Show

 instance Exception DecodeAsyncReqException

 -- ** Async matching "internals" -----------------------------------------------

 data AsyncManager = AsyncManager

   { pendingReply :: !(TVar (IntMap (TMVar (Either SomeException LB.ByteString))))

     -- ^ When a request is sent, keep track that we're expecting a reply. The

     -- /without/ a specific 'InboxId', queue it here. A request handler will

     -- pop the next request from it. (Nothing except the 'drainPipe' thread

     -- should read from the pipe). Read with @'handleAsyncReq' p get Nothing@.

   , mailboxQueues :: !(TVar (IntMap (TQueue (CorrelationId, LB.ByteString))))

     -- ^ Requests for a specific 'InboxId' that can be read using

     -- @'handleAsyncReq' p get (Just <mailboxid>)@.

 -- exclusively.

 data IddMsg  = Request !CorrelationId !(Maybe InboxId) LB.ByteString

              | Reply   !CorrelationId (Either SerializableException LB.ByteString)

 instance Binary IddMsg where

   put (Request i ii bs) = putWord8 0 >> put i >> put ii >> put bs

   put (Reply i bs)      = putWord8 1 >> put i >> put bs

   get = do

     b <- getWord8

     case b of

       0 -> Request <$> get <*> get <*> get

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

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

 newAsyncManager :: Pipe -> IO AsyncManager

   asyncFreshId  <- newIORef 0

   pendingReply  <- newTVarIO IntMap.empty

   requestsQueue <- newTQueueIO

   mailboxQueues <- newTVarIO IntMap.empty

   writeQueue <- newTQueueIO

 drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings  where

   loop = do

     readPipe p >>= \case

         loop

       -- EOF on read handle

       Nothing -> do

         -- clean up pipe then exit loop

         replyToPendings (toException PipeReadClosedException)

         pure ()

   replyToPendings e = atomically $ failPendingReplies p e

   am = pipeAsyncMngr p

 {-

 Note [Exceptions during serialization]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 (|#>) (IO fs) s = fs s

 (%>>=) :: (IO a) -> (a -> IO b) %1 -> IO b

         case m |#> s0 of -- unIO for linearity checking

           (# s1, x #) -> f x |#> s1)

 infixl 1 %>>=

   -> IO ()

 servWithCustom verbose hook pipe restore customHandler = do

   ref <- newIORef False

     loop ref mngr `finally` closePipe pipe

  where

   loop doneRef mngr = do

     when verbose $ trace "reading pipe..."

       discardCtrlC                                 %>>= \_ ->

       when verbose (trace ("msg: " ++ (show msg))) %>>= \_ ->

         CustomMessage tag payload -> handleCustom tag payload %>>= writeReply wr

         Shutdown                  -> writeIORef doneRef True >>

                                      reply ()                 %>>= writeReply wr

                                      (wrapRunTH ii (runTH pipe ii st q ty loc))

                                      (wrapRunTH ii (runModFinalizerRefs pipe ii st qs))

         _other                    -> run msg >>= reply        %>>= writeReply wr

     isDone <- readIORef doneRef

 -- | Linear and resource-safe because 'ThreadManager' is guaranteed to wait or

 -- cancel all threads.

   forkFinally

     ( mask $ \unmask -> do

         tid <- myThreadId

           else throwIO ThreadKilled

     )

     ( \ea -> fin ea )

 unsafe_linear :: (a -> b) %1 -> (a %1 -> b)

 unsafe_linear = Unsafe.unsafeCoerce (Unsafe.unsafeCoerce :: (a -> b) -> (a %1 -> b))