Add hook for creating ghci external interpreter

Summary:
The external interpreter is launched by calling
'System.Process.createProcess' with a 'CreateProcess' parameter.

The current value for this has the 'std_in', 'std_out' and 'std_err'
fields use the default of 'Inherit', meaning that the remote interpreter
shares the stdio with the original ghc/ghci process.

This patch introduces a new hook to the DynFlags, which has an
opportunity to override the 'CreateProcess' fields, launch the process,
and retrieve the stdio handles actually used.

So if a ghci external interpreter session is launched from the GHC API
the stdio can be redirected if required, which is useful for tooling/IDE
integration.

Test Plan: ./validate

Reviewers: austin, hvr, simonmar, bgamari

Reviewed By: simonmar, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2518

2 files changed, 16 insertions, 6 deletions

diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
index b4777a3c21..c6d0d229fd 100644
--- a/compiler/ghci/GHCi.hs
+++ b/compiler/ghci/GHCi.hs
@@ -60,6 +60,7 @@ import Exception
 import BasicTypes
 import FastString
 import Util
+import Hooks
 
 import Control.Concurrent
 import Control.Monad
@@ -449,7 +450,11 @@ startIServ dflags = do
       prog = pgm_i dflags ++ flavour
       opts = getOpts dflags opt_i
   debugTraceMsg dflags 3 $ text "Starting " <> text prog
-  (ph, rh, wh) <- runWithPipes prog opts
+  let createProc = lookupHook createIservProcessHook
+                              (\cp -> do { (_,_,_,ph) <- createProcess cp
+                                         ; return ph })
+                              dflags
+  (ph, rh, wh) <- runWithPipes createProc prog opts
   lo_ref <- newIORef Nothing
   cache_ref <- newIORef emptyUFM
   return $ IServ
@@ -474,7 +479,8 @@ stopIServ HscEnv{..} =
        then return ()
        else iservCall iserv Shutdown
 
-runWithPipes :: FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+runWithPipes :: (CreateProcess -> IO ProcessHandle)
+             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
 #ifdef mingw32_HOST_OS
 foreign import ccall "io.h _close"
    c__close :: CInt -> IO CInt
@@ -482,26 +488,26 @@ foreign import ccall "io.h _close"
 foreign import ccall unsafe "io.h _get_osfhandle"
    _get_osfhandle :: CInt -> IO CInt
 
-runWithPipes prog opts = do
+runWithPipes createProc prog opts = do
     (rfd1, wfd1) <- createPipeFd -- we read on rfd1
     (rfd2, wfd2) <- createPipeFd -- we write on wfd2
     wh_client    <- _get_osfhandle wfd1
     rh_client    <- _get_osfhandle rfd2
     let args = show wh_client : show rh_client : opts
-    (_, _, _, ph) <- createProcess (proc prog args)
+    ph <- createProc (proc prog args)
     rh <- mkHandle rfd1
     wh <- mkHandle wfd2
     return (ph, rh, wh)
       where mkHandle :: CInt -> IO Handle
             mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
 #else
-runWithPipes prog opts = do
+runWithPipes createProc prog opts = do
     (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
     (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
     setFdOption rfd1 CloseOnExec True
     setFdOption wfd2 CloseOnExec True
     let args = show wfd1 : show rfd2 : opts
-    (_, _, _, ph) <- createProcess (proc prog args)
+    ph <- createProc (proc prog args)
     closeFd wfd1
     closeFd rfd2
     rh <- fdToHandle rfd1
diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs
index 237101bce0..8d706d8fa5 100644
--- a/compiler/main/Hooks.hs
+++ b/compiler/main/Hooks.hs
@@ -25,6 +25,7 @@ module Hooks ( Hooks
              , runRnSpliceHook
 #ifdef GHCI
              , getValueSafelyHook
+             , createIservProcessHook
 #endif
              ) where
 
@@ -45,6 +46,7 @@ import CoreSyn
 import GHCi.RemoteTypes
 import SrcLoc
 import Type
+import System.Process
 #endif
 import BasicTypes
 
@@ -78,6 +80,7 @@ emptyHooks = Hooks
   , runRnSpliceHook        = Nothing
 #ifdef GHCI
   , getValueSafelyHook     = Nothing
+  , createIservProcessHook = Nothing
 #endif
   }
 
@@ -96,6 +99,7 @@ data Hooks = Hooks
   , runRnSpliceHook        :: Maybe (HsSplice Name -> RnM (HsSplice Name))
 #ifdef GHCI
   , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
+  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
 #endif
   }