{-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
module GHCi.Server
( serv
, defaultServer
)
where
import Prelude
import GHCi.Run
import GHCi.Signals
import GHCi.TH
import GHCi.Message
#if defined(wasm32_HOST_ARCH)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as LB
import Foreign
import Foreign.ForeignPtr.Unsafe
import GHC.Wasm.Prim
#else
import GHCi.Utils
#endif
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Concurrent (threadDelay)
import Data.Binary
import Text.Printf
import System.Environment (getProgName, getArgs)
import System.Exit
type MessageHook = Msg -> IO Msg
trace :: String -> IO ()
trace :: [Char] -> IO ()
trace [Char]
s = IO [Char]
getProgName IO [Char] -> ([Char] -> 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
>>= \[Char]
name -> [Char] -> [Char] -> [Char] -> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"[%20s] %s\n" [Char]
name [Char]
s
serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv :: Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()
serv Bool
verbose MessageHook
hook Pipe
pipe forall a. IO a -> IO a
restore = IO ()
loop
where
loop :: IO ()
loop = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace [Char]
"reading pipe..."
Msg msg <- Pipe -> Get Msg -> IO Msg
forall a. Pipe -> Get a -> IO a
readPipe Pipe
pipe Get Msg
getMessage IO Msg -> MessageHook -> IO Msg
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageHook
hook
discardCtrlC
when verbose $ trace ("msg: " ++ (show msg))
case msg of
Message a
Shutdown -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RunTH RemoteRef (IORef QState)
st HValueRef
q THResultType
ty Maybe Loc
loc -> IO ByteString -> IO ()
forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Pipe
-> RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe Loc
-> IO ByteString
runTH Pipe
pipe RemoteRef (IORef QState)
st HValueRef
q THResultType
ty Maybe Loc
loc
RunModFinalizers RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs -> IO () -> IO ()
forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Pipe -> RemoteRef (IORef QState) -> [RemoteRef (Q ())] -> IO ()
runModFinalizerRefs Pipe
pipe RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs
Message a
_other -> Message a -> IO a
forall a. Message a -> IO a
run Message a
msg IO a -> (a -> 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
>>= a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply
reply :: forall a. (Binary a, Show a) => a -> IO ()
reply :: forall a. (Binary a, Show a) => a -> IO ()
reply a
r = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace ([Char]
"writing pipe: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
r)
Pipe -> Put -> IO ()
writePipe Pipe
pipe (a -> Put
forall t. Binary t => t -> Put
put a
r)
IO ()
loop
wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH IO a
io = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace [Char]
"wrapRunTH..."
r <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
when verbose $ trace "wrapRunTH done."
when verbose $ trace "writing RunTHDone."
writePipe pipe (putTHMessage RunTHDone)
case r of
Left SomeException
e
| Just (GHCiQException QState
_ [Char]
err) <- SomeException -> Maybe GHCiQException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace ([Char]
"QFail " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
err)
QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply ([Char] -> QResult a
forall a. [Char] -> QResult a
QFail [Char]
err :: QResult a)
| Bool
otherwise -> do
str <- SomeException -> IO [Char]
showException SomeException
e
when verbose $ trace ("QException " ++ str)
reply (QException str :: QResult a)
Right a
a -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace [Char]
"QDone"
QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (a -> QResult a
forall a. a -> QResult a
QDone a
a)
showException :: SomeException -> IO String
showException :: SomeException -> IO [Char]
showException SomeException
e0 = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace [Char]
"showException"
r <- IO [Char] -> IO (Either SomeException [Char])
forall e a. Exception e => IO a -> IO (Either e a)
try (IO [Char] -> IO (Either SomeException [Char]))
-> IO [Char] -> IO (Either SomeException [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
forall a. a -> IO a
evaluate ([Char] -> [Char]
forall a. NFData a => a -> a
force (SomeException -> [Char]
forall a. Show a => a -> [Char]
show (SomeException
e0::SomeException)))
case r of
Left SomeException
e -> SomeException -> IO [Char]
showException SomeException
e
Right [Char]
str -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
str
discardCtrlC :: IO ()
discardCtrlC = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
trace [Char]
"discardCtrlC"
r <- IO () -> IO (Either AsyncException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either AsyncException ()))
-> IO () -> IO (Either AsyncException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case r of
Left AsyncException
UserInterrupt -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
discardCtrlC
Left AsyncException
e -> AsyncException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO AsyncException
e
Either AsyncException ()
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if defined(wasm32_HOST_ARCH)
defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
defaultServer cb_sig cb_recv cb_send = do
args <- getArgs
let rest = args
#else
defaultServer :: IO ()
defaultServer :: IO ()
defaultServer = do
args <- IO [[Char]]
getArgs
(outh, inh, rest) <-
case args of
[Char]
arg0:[Char]
arg1:[[Char]]
rest -> do
inh <- [Char] -> IO Handle
readGhcHandle [Char]
arg1
outh <- readGhcHandle arg0
return (outh, inh, rest)
[[Char]]
_ -> IO (Handle, Handle, [[Char]])
forall a. IO a
dieWithUsage
#endif
(verbose, rest') <- case rest of
[Char]
"-v":[[Char]]
rest' -> (Bool, [[Char]]) -> IO (Bool, [[Char]])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [[Char]]
rest')
[[Char]]
_ -> (Bool, [[Char]]) -> IO (Bool, [[Char]])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [[Char]]
rest)
(wait, rest'') <- case rest' of
[Char]
"-wait":[[Char]]
rest'' -> (Bool, [[Char]]) -> IO (Bool, [[Char]])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [[Char]]
rest'')
[[Char]]
_ -> (Bool, [[Char]]) -> IO (Bool, [[Char]])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [[Char]]
rest')
unless (null rest'') $
dieWithUsage
#if defined(wasm32_HOST_ARCH)
installSignalHandlers $ js_register_signal_handler cb_sig
pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send)
#else
when verbose $
printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh)
installSignalHandlers
pipe <- mkPipeFromHandles inh outh
#endif
when wait $ do
when verbose $
putStrLn "Waiting 3s"
threadDelay 3000000
uninterruptibleMask $ serv verbose hook pipe
where hook :: a -> IO a
hook = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
dieWithUsage :: IO a
dieWithUsage :: forall a. IO a
dieWithUsage = do
prog <- IO [Char]
getProgName
die $ prog ++ ": " ++ msg
where
#if defined(WINDOWS)
msg = "usage: iserv <write-handle> <read-handle> [-v]"
#else
msg :: [Char]
msg = [Char]
"usage: iserv <write-fd> <read-fd> [-v]"
#endif
#if defined(wasm32_HOST_ARCH)
newtype Callback a = Callback JSVal
newtype JSUint8Array = JSUint8Array { unJSUint8Array :: JSVal }
recv_buf :: Callback (IO JSUint8Array) -> IO ByteString
recv_buf cb = do
buf <- js_recv_buf cb
len <- js_buf_len buf
fp <- mallocForeignPtrBytes len
js_download_buf buf $ unsafeForeignPtrToPtr fp
freeJSVal $ unJSUint8Array buf
evaluate $ B.fromForeignPtr0 fp len
send_buf :: Callback (JSUint8Array -> IO ()) -> B.Builder -> IO ()
send_buf cb b = do
buf <- evaluate $ LB.toStrict $ B.toLazyByteString b
B.unsafeUseAsCStringLen buf $ \(ptr, len) -> js_send_buf cb ptr len
foreign import javascript unsafe "dynamic"
js_register_signal_handler :: Callback (JSVal -> IO ()) -> JSVal -> IO ()
foreign import javascript "dynamic"
js_recv_buf :: Callback (IO JSUint8Array) -> IO JSUint8Array
foreign import javascript unsafe "$1.byteLength"
js_buf_len :: JSUint8Array -> IO Int
foreign import javascript unsafe "(new Uint8Array(__exports.memory.buffer, $2, $1.byteLength)).set($1)"
js_download_buf :: JSUint8Array -> Ptr a -> IO ()
foreign import javascript unsafe "$1(new Uint8Array(__exports.memory.buffer, $2, $3))"
js_send_buf :: Callback (JSUint8Array -> IO ()) -> Ptr a -> Int -> IO ()
foreign export javascript "defaultServer"
defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
#endif