Merge libiserv with ghci

`libiserv` serves no purpose. As it depends on `ghci` and doesn't have
more dependencies than the `ghci` package, its code could live in the
`ghci` package too.

This commit also moves most of the code from the `iserv` program into
the `ghci` package as well so that it can be reused. This is especially
useful for the implementation of TH for the JS backend (#22261, !9779).

2 files changed, 219 insertions, 0 deletions

diff --git a/libraries/ghci/GHCi/Server.hs b/libraries/ghci/GHCi/Server.hs
new file mode 100644
index 0000000000..f46060a01c
--- /dev/null
+++ b/libraries/ghci/GHCi/Server.hs
@@ -0,0 +1,148 @@
+{-# 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 s = getProgName >>= \name -> printf "[%20s] %s\n" name s
+
+serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
+serv verbose hook pipe restore = loop
+ where
+  loop = do
+    when verbose $ trace "reading pipe..."
+    Msg msg <- readPipe pipe getMessage >>= hook
+
+    discardCtrlC
+
+    when verbose $ trace ("msg: " ++ (show msg))
+    case msg of
+      Shutdown -> return ()
+      RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
+      RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
+      _other -> run msg >>= reply
+
+  reply :: forall a. (Binary a, Show a) => a -> IO ()
+  reply r = do
+    when verbose $ trace ("writing pipe: " ++ show r)
+    writePipe pipe (put r)
+    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 io = do
+    when verbose $ trace "wrapRunTH..."
+    r <- try io
+    when verbose $ trace "wrapRunTH done."
+    when verbose $ trace "writing RunTHDone."
+    writePipe pipe (putTHMessage RunTHDone)
+    case r of
+      Left e
+        | Just (GHCiQException _ err) <- fromException e  -> do
+           when verbose $ trace ("QFail " ++ show err)
+           reply (QFail err :: QResult a)
+        | otherwise -> do
+           str <- showException e
+           when verbose $ trace ("QException " ++ str)
+           reply (QException str :: QResult a)
+      Right a -> do
+        when verbose $ trace "QDone"
+        reply (QDone 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 e0 = do
+     when verbose $ trace "showException"
+     r <- try $ evaluate (force (show (e0::SomeException)))
+     case r of
+       Left e -> showException e
+       Right str -> return 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 = do
+    when verbose $ trace "discardCtrlC"
+    r <- try $ restore $ return ()
+    case r of
+      Left UserInterrupt -> return () >> discardCtrlC
+      Left e -> throwIO e
+      _ -> return ()
+
+-- | Default server
+defaultServer :: IO ()
+defaultServer = do
+  args <- getArgs
+  (outh, inh, rest) <-
+      case args of
+        arg0:arg1:rest -> do
+            inh  <- readGhcHandle arg1
+            outh <- readGhcHandle arg0
+            return (outh, inh, rest)
+        _ -> dieWithUsage
+
+  (verbose, rest') <- case rest of
+    "-v":rest' -> return (True, rest')
+    _ -> return (False, rest)
+
+  (wait, rest'') <- case rest' of
+    "-wait":rest'' -> return (True, rest'')
+    _ -> return (False, 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 = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
+
+  when wait $ do
+    when verbose $
+      putStrLn "Waiting 3s"
+    threadDelay 3000000
+
+  uninterruptibleMask $ serv verbose hook pipe
+
+  where hook = 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 = do
+    prog <- getProgName
+    die $ prog ++ ": " ++ msg
+  where
+#if defined(WINDOWS)
+    msg = "usage: iserv <write-handle> <read-handle> [-v]"
+#else
+    msg = "usage: iserv <write-fd> <read-fd> [-v]"
+#endif
+
diff --git a/libraries/ghci/GHCi/Utils.hsc b/libraries/ghci/GHCi/Utils.hsc
new file mode 100644
index 0000000000..43ab4a8550
--- /dev/null
+++ b/libraries/ghci/GHCi/Utils.hsc
@@ -0,0 +1,71 @@
+{-# LANGUAGE CPP #-}
+module GHCi.Utils
+  ( getGhcHandle
+  , readGhcHandle
+  )
+where
+
+import Prelude
+import Foreign.C
+import GHC.IO.Handle (Handle())
+#if defined(mingw32_HOST_OS)
+import Foreign.Ptr (ptrToIntPtr,wordPtrToPtr)
+import GHC.IO (onException)
+import GHC.IO.Handle.FD (fdToHandle)
+import GHC.Windows (HANDLE)
+import GHC.IO.SubSystem ((<!>))
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
+import GHC.IO.Device as IODevice
+import GHC.IO.Encoding (getLocaleEncoding)
+import GHC.IO.IOMode
+import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
+
+#include <fcntl.h>     /* for _O_BINARY */
+
+#else
+import System.Posix
+#endif
+
+-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd.
+
+#if defined(mingw32_HOST_OS)
+getGhcHandle :: HANDLE -> IO Handle
+getGhcHandle = getGhcHandlePOSIX <!> getGhcHandleNative
+
+getGhcHandlePOSIX :: HANDLE -> IO Handle
+getGhcHandlePOSIX handle = do
+  let intptr = ptrToIntPtr handle
+  _open_osfhandle (fromIntegral intptr) (#const _O_BINARY) >>= fdToHandle
+
+getGhcHandleNative :: HANDLE -> IO Handle
+getGhcHandleNative hwnd =
+  do mb_codec <- fmap Just getLocaleEncoding
+     let iomode = ReadWriteMode
+         native_handle = fromHANDLE hwnd :: Io NativeHandle
+     hw_type <- IODevice.devType $ native_handle
+     mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec
+       `onException` IODevice.close native_handle
+
+foreign import ccall "io.h _open_osfhandle" _open_osfhandle ::
+    CInt -> CInt -> IO CInt
+#else
+getGhcHandle :: CInt -> IO Handle
+getGhcHandle fd     = fdToHandle $ Fd fd
+#endif
+
+-- | Read a handle passed on the command-line and prepare it to be used with the IO manager
+readGhcHandle :: String -> IO Handle
+readGhcHandle s = do
+#if defined(mingw32_HOST_OS)
+  let fd = wordPtrToPtr (Prelude.read s)
+# if defined(__IO_MANAGER_WINIO__)
+  -- register the handles we received with
+  -- our I/O manager otherwise we can't use
+  -- them correctly.
+  return () <!> associateHandle' fd
+# endif
+#else
+  let fd = Prelude.read s
+#endif
+  getGhcHandle fd
+