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

    import Prelude
    import GHCi.Run
    import GHCi.TH
    import GHCi.Message
    import GHCi.Signals
    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)
      installSignalHandlers
      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