summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Utility/Process.hs37
1 files changed, 36 insertions, 1 deletions
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 53b6d2f2f..ed837a16c 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -161,6 +161,8 @@ createBackgroundProcess p a = a =<< createProcess p
- whether it succeeded or failed. -}
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
processTranscript cmd opts input = do
(readf, writef) <- createPipe
readh <- fdToHandle readf
@@ -195,7 +197,40 @@ processTranscript cmd opts input = do
ok <- checkSuccessProcess pid
return (transcript, ok)
#else
-processTranscript = error "processTranscript TODO"
+{- This implementation for Windows puts stderr after stdout. -}
+processTranscript cmd opts input = do
+ p@(_, _, _, pid) <- createProcess $
+ (proc cmd opts)
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+
+ getout <- mkreader (stdoutHandle p)
+ geterr <- mkreader (stderrHandle p)
+
+ case input of
+ Just s -> do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ Nothing -> return ()
+
+ transcript <- (++) <$> getout <*> geterr
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+ where
+ mkreader h = do
+ s <- hGetContents h
+ v <- newEmptyMVar
+ void $ forkIO $ do
+ E.evaluate (length s)
+ putMVar v ()
+ return $ do
+ takeMVar v
+ return s
#endif
{- Runs a CreateProcessRunner, on a CreateProcess structure, that