{-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
module GHCi.Server
  ( serv
  , defaultServer
  )
where

import Prelude
import GHCi.Run
import GHCi.TH
import GHCi.Message
#if !defined(wasm32_HOST_ARCH)
import GHCi.Signals
#endif
import GHCi.Utils

import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Concurrent (threadDelay)
import Data.Binary
import Data.IORef

import Text.Printf
import System.Environment (getProgName, getArgs)
import System.Exit

type MessageHook = Msg -> IO Msg

trace :: String -> IO ()
trace :: String -> IO ()
trace String
s = IO String
getProgName IO String -> (String -> 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
>>= \String
name -> String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"[%20s] %s\n" String
name String
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
$ String -> IO ()
trace String
"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
$ String -> IO ()
trace (String
"writing pipe: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
r)
    Pipe -> Put -> IO ()
writePipe Pipe
pipe (a -> Put
forall t. Binary t => t -> Put
put a
r)
    IO ()
loop

  -- Run some TH code, which may interact with GHC by sending
  -- 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.
  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
$ String -> IO ()
trace String
"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
_ String
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
$ String -> IO ()
trace (String
"QFail " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
err)
           QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (String -> QResult a
forall a. String -> QResult a
QFail String
err :: QResult a)
        | Bool
otherwise -> do
           str <- SomeException -> IO String
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
$ String -> IO ()
trace String
"QDone"
        QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (a -> QResult a
forall a. a -> QResult a
QDone a
a)

  -- carefully when showing an exception, there might be other exceptions
  -- lurking inside it.  If so, we return the inner exception instead.
  showException :: SomeException -> IO String
  showException :: SomeException -> IO String
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
$ String -> IO ()
trace String
"showException"
     r <- IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e0::SomeException)))
     case r of
       Left SomeException
e -> SomeException -> IO String
showException SomeException
e
       Right String
str -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

  -- throw away any pending ^C exceptions while we're not running
  -- interpreted code.  GHC will also get the ^C, and either ignore it
  -- (if this is GHCi), or tell us to quit with a Shutdown message.
  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
$ String -> IO ()
trace String
"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 ()

-- | Default server
defaultServer :: IO ()
defaultServer :: IO ()
defaultServer = do
  args <- IO [String]
getArgs
  (outh, inh, rest) <-
      case args of
        String
arg0:String
arg1:[String]
rest -> do
            inh  <- String -> IO Handle
readGhcHandle String
arg1
            outh <- readGhcHandle arg0
            return (outh, inh, rest)
        [String]
_ -> IO (Handle, Handle, [String])
forall a. IO a
dieWithUsage

  (verbose, rest') <- case rest of
    String
"-v":[String]
rest' -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [String]
rest')
    [String]
_ -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [String]
rest)

  (wait, rest'') <- case rest' of
    String
"-wait":[String]
rest'' -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [String]
rest'')
    [String]
_ -> (Bool, [String]) -> IO (Bool, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [String]
rest')

  unless (null rest'') $
    dieWithUsage

  when verbose $
    printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh)

#if !defined(wasm32_HOST_ARCH)
  installSignalHandlers
#endif

  lo_ref <- newIORef Nothing
  let pipe = Pipe{pipeRead :: Handle
pipeRead = Handle
inh, pipeWrite :: Handle
pipeWrite = Handle
outh, pipeLeftovers :: IORef (Maybe ByteString)
pipeLeftovers = IORef (Maybe ByteString)
lo_ref}

  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 -- empty hook
    -- we cannot allow any async exceptions while communicating, because
    -- we will lose sync in the protocol, hence uninterruptibleMask.

dieWithUsage :: IO a
dieWithUsage :: forall a. IO a
dieWithUsage = do
    prog <- IO String
getProgName
    die $ prog ++ ": " ++ msg
  where
#if defined(WINDOWS)
    msg = "usage: iserv <write-handle> <read-handle> [-v]"
#else
    msg :: String
msg = String
"usage: iserv <write-fd> <read-fd> [-v]"
#endif

#if defined(wasm32_HOST_ARCH)

foreign export javascript "defaultServer" defaultServer :: IO ()

#endif