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

      -- 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
    $ [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)

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

      -- 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
    $ [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 ()

    -- | Default server
    #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)
      -- See Note [wasm ghci signal handlers] for details
      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 -- 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 [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