{-# LANGUAGE LambdaCase #-}
module GHC.Runtime.Interpreter.Process
  (
  -- * Message API
    Message(..)
  , DelayedResponse (..)
  -- * Top-level message API (these acquire/release a lock)
  , sendMessage
  , sendMessageNoResponse
  , sendMessageDelayedResponse
  , receiveDelayedResponse
  -- * Nested message API (these require the interpreter to already be locked)
  , sendAnyValue
  , receiveAnyValue
  , 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
import Control.Concurrent.MVar (MVar, withMVar, takeMVar, putMVar, isEmptyMVar)

data DelayedResponse a = DelayedResponse

-- -----------------------------------------------------------------------------
-- Top-level Message API

-- | Send a message to the interpreter process that doesn't expect a response
--   (locks the interpreter while sending)
sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse :: forall d. ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse ExtInterpInstance d
i Message ()
m =
  ExtInterpInstance d -> IO () -> IO ()
forall d a. ExtInterpInstance d -> IO a -> IO a
withLock ExtInterpInstance d
i (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 expects a response
--   (locks the interpreter while until the response is received)
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 = ExtInterpInstance d -> IO a -> IO a
forall d a. ExtInterpInstance d -> IO a -> IO a
withLock ExtInterpInstance d
i (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ 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.
-- (locks the interpreter until the response is received using
-- `receiveDelayedResponse`)
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
  ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
lock ExtInterpInstance d
i
  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

-- | 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 = do
  ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i
  r <- 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
  unlock i
  pure r

-- -----------------------------------------------------------------------------
-- Nested Message API

-- | Send any value (requires locked interpreter)
sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO ()
sendAnyValue :: forall a d. Binary a => ExtInterpInstance d -> a -> IO ()
sendAnyValue ExtInterpInstance d
i a
m = ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 (requires locked interpreter)
receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a
receiveAnyValue :: forall d a. ExtInterpInstance d -> Get a -> IO a
receiveAnyValue ExtInterpInstance d
i Get a
get = ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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

-- | Wait for a Template Haskell message (requires locked interpreter)
receiveTHMessage :: ExtInterpInstance d -> IO THMsg
receiveTHMessage :: forall d. ExtInterpInstance d -> IO THMsg
receiveTHMessage ExtInterpInstance d
i = ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i IO () -> IO THMsg -> IO THMsg
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtInterpInstance d -> Get THMsg -> IO THMsg
forall d a. ExtInterpInstance d -> Get a -> IO a
receiveAnyValue ExtInterpInstance d
i Get THMsg
getTHMessage

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

getLock :: ExtInterpInstance d -> MVar ()
getLock :: forall d. ExtInterpInstance d -> MVar ()
getLock = InterpProcess -> MVar ()
interpLock (InterpProcess -> MVar ())
-> (ExtInterpInstance d -> InterpProcess)
-> ExtInterpInstance d
-> MVar ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess

withLock :: ExtInterpInstance d -> IO a -> IO a
withLock :: forall d a. ExtInterpInstance d -> IO a -> IO a
withLock ExtInterpInstance d
i IO a
f = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i) (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
f)

lock :: ExtInterpInstance d -> IO ()
lock :: forall d. ExtInterpInstance d -> IO ()
lock ExtInterpInstance d
i = MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i)

unlock :: ExtInterpInstance d -> IO ()
unlock :: forall d. ExtInterpInstance d -> IO ()
unlock ExtInterpInstance d
i = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i) ()

ensureLocked :: ExtInterpInstance d -> IO ()
ensureLocked :: forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i =
  MVar () -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i) IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> String -> IO ()
forall a. HasCallStack => String -> a
panic String
"ensureLocked: external interpreter not locked"
    Bool
_     -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | 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