    {-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
    module IServ (serv) where

    import GHCi.Run
    import GHCi.TH
    import GHCi.Message

    import Control.DeepSeq
    import Control.Exception
    import Control.Monad
    import Data.Binary

    import Text.Printf
    import System.Environment (getProgName)

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

        IO ()
    discardCtrlC

        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
    "msg: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Message a -> String
    forall a. Show a => a -> String
    show Message a
    msg))
        case Message a
    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..."
        Either SomeException a
    r <- IO a -> IO (Either SomeException a)
    forall e a. Exception e => IO a -> IO (Either e a)
    try IO a
    io
        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 done."
        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 RunTHDone."
        Pipe -> Put -> IO ()
    writePipe Pipe
    pipe (THMessage () -> Put
    forall a. THMessage a -> Put
    putTHMessage THMessage ()
    RunTHDone)
        case Either SomeException a
    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
               String
    str <- SomeException -> IO String
    showException SomeException
    e
               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
    "QException " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str)
               QResult a -> IO ()
    forall a. (Binary a, Show a) => a -> IO ()
    reply (String -> QResult a
    forall a. String -> QResult a
    QException String
    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"
         Either SomeException String
    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 Either SomeException String
    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"
        Either AsyncException ()
    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 Either AsyncException ()
    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. 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 ()