module GHC.Runtime.Interpreter.Process
  (
  -- * Low-level API
    callInterpProcess
  , readInterpProcess
  , writeInterpProcess

  -- * Message API
  , Message(..)
  , DelayedResponse (..)
  , sendMessage
  , sendMessageNoResponse
  , sendMessageDelayedResponse
  , sendAnyValue
  , receiveAnyValue
  , receiveDelayedResponse
  , receiveTHMessage

  )
where

import GHC.Prelude

import GHC.Runtime.Interpreter.Types
import GHCi.Message

import GHC.IO (catchException)
import GHC.Utils.Panic
import GHC.Utils.Exception as Ex

import Data.Binary
import System.Exit
import System.Process

data DelayedResponse a = DelayedResponse

-- | Send a message to the interpreter process that doesn't expect a response
sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse :: forall d. ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse ExtInterpInstance d
i Message ()
m = InterpProcess -> Put -> IO ()
writeInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) (Message () -> Put
forall a. Message a -> Put
putMessage Message ()
m)

-- | Send a message to the interpreter that excepts a response
sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage :: forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance d
i Message a
m = InterpProcess -> Message a -> IO a
forall a. Binary a => InterpProcess -> Message a -> IO a
callInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) Message a
m

-- | Send a message to the interpreter process whose response is expected later
--
-- This is useful to avoid forgetting to receive the value and to ensure that
-- the type of the response isn't lost. Use receiveDelayedResponse to read it.
sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a)
sendMessageDelayedResponse :: forall d a.
ExtInterpInstance d -> Message a -> IO (DelayedResponse a)
sendMessageDelayedResponse ExtInterpInstance d
i Message a
m = do
  InterpProcess -> Put -> IO ()
writeInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) (Message a -> Put
forall a. Message a -> Put
putMessage Message a
m)
  DelayedResponse a -> IO (DelayedResponse a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DelayedResponse a
forall {k} (a :: k). DelayedResponse a
DelayedResponse

-- | Send any value
sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO ()
sendAnyValue :: forall a d. Binary a => ExtInterpInstance d -> a -> IO ()
sendAnyValue ExtInterpInstance d
i a
m = InterpProcess -> Put -> IO ()
writeInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) (a -> Put
forall t. Binary t => t -> Put
put a
m)

-- | Expect a value to be received
receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a
receiveAnyValue :: forall d a. ExtInterpInstance d -> Get a -> IO a
receiveAnyValue ExtInterpInstance d
i Get a
get = InterpProcess -> Get a -> IO a
forall a. InterpProcess -> Get a -> IO a
readInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) Get a
get

-- | Expect a delayed result to be received now
receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a
receiveDelayedResponse :: forall a d.
Binary a =>
ExtInterpInstance d -> DelayedResponse a -> IO a
receiveDelayedResponse ExtInterpInstance d
i DelayedResponse a
DelayedResponse = InterpProcess -> Get a -> IO a
forall a. InterpProcess -> Get a -> IO a
readInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) Get a
forall t. Binary t => Get t
get

-- | Expect a value to be received
receiveTHMessage :: ExtInterpInstance d -> IO THMsg
receiveTHMessage :: forall d. ExtInterpInstance d -> IO THMsg
receiveTHMessage ExtInterpInstance d
i = ExtInterpInstance d -> Get THMsg -> IO THMsg
forall d a. ExtInterpInstance d -> Get a -> IO a
receiveAnyValue ExtInterpInstance d
i Get THMsg
getTHMessage


-- -----------------------------------------------------------------------------
-- Low-level API

-- | Send a 'Message' and receive the response from the interpreter process
callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a
callInterpProcess :: forall a. Binary a => InterpProcess -> Message a -> IO a
callInterpProcess InterpProcess
i Message a
msg =
  Pipe -> Message a -> IO a
forall a. Binary a => Pipe -> Message a -> IO a
remoteCall (InterpProcess -> Pipe
interpPipe InterpProcess
i) Message a
msg
    IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(SomeException
e :: SomeException) -> InterpProcess -> SomeException -> IO a
forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e

-- | Read a value from the interpreter process
readInterpProcess :: InterpProcess -> Get a -> IO a
readInterpProcess :: forall a. InterpProcess -> Get a -> IO a
readInterpProcess InterpProcess
i Get a
get =
  Pipe -> Get a -> IO a
forall a. Pipe -> Get a -> IO a
readPipe (InterpProcess -> Pipe
interpPipe InterpProcess
i) Get a
get
    IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(SomeException
e :: SomeException) -> InterpProcess -> SomeException -> IO a
forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e

-- | Send a value to the interpreter process
writeInterpProcess :: InterpProcess -> Put -> IO ()
writeInterpProcess :: InterpProcess -> Put -> IO ()
writeInterpProcess InterpProcess
i Put
put =
  Pipe -> Put -> IO ()
writePipe (InterpProcess -> Pipe
interpPipe InterpProcess
i) Put
put
    IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(SomeException
e :: SomeException) -> InterpProcess -> SomeException -> IO ()
forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e

handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a
handleInterpProcessFailure :: forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e = do
  let hdl :: ProcessHandle
hdl = InterpProcess -> ProcessHandle
interpHandle InterpProcess
i
  ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
hdl
  case ex of
    Just (ExitFailure Int
n) ->
      GhcException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> GhcException
InstallationError (String
"External interpreter terminated (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))
    Maybe ExitCode
_ -> do
      ProcessHandle -> IO ()
terminateProcess ProcessHandle
hdl
      _ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
hdl
      throw e