[commit: ghc] ghc-8.0: Add hook for creating ghci external interpreter (daa4de5)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/daa4de57c9faa3ee471fca92386360e1a06c382b/ghc

>---------------------------------------------------------------

commit daa4de57c9faa3ee471fca92386360e1a06c382b
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date:   Thu Sep 8 08:59:48 2016 +0200

    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
    
    (cherry picked from commit 65d9597d98ead78198bb747aed4e1163ee0d60d3)


>---------------------------------------------------------------

daa4de57c9faa3ee471fca92386360e1a06c382b
 compiler/ghci/GHCi.hs  | 18 ++++++++++++------
 compiler/main/Hooks.hs |  4 ++++
 2 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
index 7097e66..094993d 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
@@ -442,7 +443,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
@@ -467,7 +472,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
@@ -475,26 +481,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 237101b..8d706d8 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
   }