[commit: packages/Cabal] ghc-head: Fix cabal repl handling of Ctrl-C (242f5ce)

[git at git.haskell.org]

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

On branch  : ghc-head
Link       : http://git.haskell.org/packages/Cabal.git/commitdiff/242f5cec045ab8d6a9099889c67c831fc4bb97cd

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

commit 242f5cec045ab8d6a9099889c67c831fc4bb97cd
Author: Jason Dagit <dagitj at gmail.com>
Date:   Mon Oct 7 16:38:42 2013 -0700

    Fix cabal repl handling of Ctrl-C
    
    (cherry picked from commit c37f032d5b57c8a02fc2e12718bf223508300927)


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

242f5cec045ab8d6a9099889c67c831fc4bb97cd
 Cabal/Distribution/Simple/Utils.hs |   57 +++++++++++++++++++++++++++++++-----
 1 file changed, 49 insertions(+), 8 deletions(-)

diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index b1ec276..7fd9a07 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/Cabal/Distribution/Simple/Utils.hs
@@ -195,14 +195,20 @@ import Distribution.Version
     (Version(..))
 
 import Control.Exception (IOException, evaluate, throwIO)
-import System.Process (rawSystem, runProcess)
+import System.Process (rawSystem, CreateProcess(..))
 
 import Control.Concurrent (forkIO)
-import System.Process (runInteractiveProcess, waitForProcess)
+import System.Process (runInteractiveProcess, waitForProcess, proc, StdStream(..))
 #if __GLASGOW_HASKELL__ >= 702
 import System.Process (showCommandForUser)
 #endif
 
+#if !mingw32_HOST_OS
+import System.Posix.Signals ( installHandler, sigINT, sigQUIT, Handler(..) )
+#endif
+
+import System.Process.Internals ( runGenProcess_, defaultSignal )
+
 import Distribution.Compat.CopyFile
          ( copyFile, copyOrdinaryFile, copyExecutableFile
          , setFileOrdinary, setFileExecutable, setDirOrdinary )
@@ -381,6 +387,34 @@ printRawCommandAndArgsAndEnv verbosity path args env
  | verbosity >= verbose   = putStrLn $ unwords (path : args)
  | otherwise              = return ()
 
+
+-- This is taken directly from the process package.
+-- The reason we need it is that runProcess doesn't handle ^C in the same
+-- way that rawSystem handles it, but rawSystem doesn't allow us to pass
+-- an environment.
+syncProcess :: String -> CreateProcess -> IO ExitCode
+#if mingw32_HOST_OS
+syncProcess _fun c = do
+  (_,_,_,p) <- createProcess c
+  waitForProcess p
+#else
+syncProcess fun c = do
+  -- The POSIX version of system needs to do some manipulation of signal
+  -- handlers.  Since we're going to be synchronously waiting for the child,
+  -- we want to ignore ^C in the parent, but handle it the default way
+  -- in the child (using SIG_DFL isn't really correct, it should be the
+  -- original signal handler, but the GHC RTS will have already set up
+  -- its own handler and we don't want to use that).
+  old_int  <- installHandler sigINT  Ignore Nothing
+  old_quit <- installHandler sigQUIT Ignore Nothing
+  (_,_,_,p) <- runGenProcess_ fun c
+                (Just defaultSignal) (Just defaultSignal)
+  r <- waitForProcess p
+  _ <- installHandler sigINT  old_int Nothing
+  _ <- installHandler sigQUIT old_quit Nothing
+  return r
+#endif  /* mingw32_HOST_OS */
+
 -- Exit with the same exitcode if the subcommand fails
 rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
 rawSystemExit verbosity path args = do
@@ -405,11 +439,10 @@ rawSystemExitWithEnv :: Verbosity
                      -> [String]
                      -> [(String, String)]
                      -> IO ()
-rawSystemExitWithEnv verbosity path args env = do
-    printRawCommandAndArgsAndEnv verbosity path args env
+rawSystemExitWithEnv verbosity path args env' = do
+    printRawCommandAndArgsAndEnv verbosity path args env'
     hFlush stdout
-    ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing
-    exitcode <- waitForProcess ph
+    exitcode <- syncProcess "rawSystemExitWithEnv" (proc path args) { env = Just env' }
     unless (exitcode == ExitSuccess) $ do
         debug verbosity $ path ++ " returned " ++ show exitcode
         exitWith exitcode
@@ -428,11 +461,19 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do
     maybe (printRawCommandAndArgs       verbosity path args)
           (printRawCommandAndArgsAndEnv verbosity path args) menv
     hFlush stdout
-    ph <- runProcess path args mcwd menv inp out err
-    exitcode <- waitForProcess ph
+    exitcode <- syncProcess "rawSystemIOWithEnv" (proc path args) { cwd     = mcwd
+                                                                  , env     = menv
+                                                                  , std_in  = mbToStd inp
+                                                                  , std_out = mbToStd out
+                                                                  , std_err = mbToStd err }
     unless (exitcode == ExitSuccess) $ do
       debug verbosity $ path ++ " returned " ++ show exitcode
     return exitcode
+  where
+  -- Also taken from System.Process
+  mbToStd :: Maybe Handle -> StdStream
+  mbToStd Nothing    = Inherit
+  mbToStd (Just hdl) = UseHandle hdl
 
 -- | Run a command and return its output.
 --