summaryrefslogtreecommitdiff
path: root/src/System
diff options
context:
space:
mode:
authorJoey Hess2015-11-06 12:46:52 -0400
committerJoey Hess2015-11-06 12:46:52 -0400
commitd50aa85052b1f35021072ea95bc51b5c46c797b0 (patch)
treebc7e94f6bc142959dbef097b86f9efa95bedaaec /src/System
parent8ed7d71bda9efd6af870ac926d2d907f71168798 (diff)
merge from concurrent-output
Diffstat (limited to 'src/System')
-rw-r--r--src/System/Console/Concurrent.hs5
-rw-r--r--src/System/Console/Concurrent/Internal.hs44
2 files changed, 35 insertions, 14 deletions
diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs
index efbfaa15..12447637 100644
--- a/src/System/Console/Concurrent.hs
+++ b/src/System/Console/Concurrent.hs
@@ -14,13 +14,18 @@
-- > `concurrently`
-- > createProcessConcurrent (proc "ls" [])
+{-# LANGUAGE CPP #-}
+
module System.Console.Concurrent (
-- * Concurrent output
withConcurrentOutput,
Outputable(..),
outputConcurrent,
+ errorConcurrent,
ConcurrentProcessHandle,
+#ifndef mingw32_HOST_OS
createProcessConcurrent,
+#endif
waitForProcessConcurrent,
createProcessForeground,
flushConcurrentOutput,
diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs
index 0862ec46..f538a7de 100644
--- a/src/System/Console/Concurrent/Internal.hs
+++ b/src/System/Console/Concurrent/Internal.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
+{-# LANGUAGE CPP #-}
-- |
-- Copyright: 2015 Joey Hess <id@joeyh.name>
@@ -11,7 +12,9 @@
module System.Console.Concurrent.Internal where
import System.IO
+#ifndef mingw32_HOST_OS
import System.Posix.IO
+#endif
import System.Directory
import System.Exit
import Control.Monad
@@ -149,19 +152,29 @@ instance Outputable String where
-- not block. It buffers the value, so it will be displayed once the other
-- writer is done.
outputConcurrent :: Outputable v => v -> IO ()
-outputConcurrent v = bracket setup cleanup go
+outputConcurrent = outputConcurrent' StdOut
+
+-- | Like `outputConcurrent`, but displays to stderr.
+--
+-- (Does not throw an exception.)
+errorConcurrent :: Outputable v => v -> IO ()
+errorConcurrent = outputConcurrent' StdErr
+
+outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()
+outputConcurrent' stdh v = bracket setup cleanup go
where
setup = tryTakeOutputLock
cleanup False = return ()
cleanup True = dropOutputLock
go True = do
- T.hPutStr stdout (toOutput v)
- hFlush stdout
+ T.hPutStr h (toOutput v)
+ hFlush h
go False = do
- let bv = outputBuffer globalOutputHandle
oldbuf <- atomically $ takeTMVar bv
newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf
atomically $ putTMVar bv newbuf
+ h = toHandle stdh
+ bv = bufferFor stdh
newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle
@@ -243,6 +256,9 @@ asyncProcessWaiter waitaction = do
-- the process is instead run with its stdout and stderr
-- redirected to a buffer. The buffered output will be displayed as soon
-- as the output lock becomes free.
+--
+-- Currently only available on Unix systems, not Windows.
+#ifndef mingw32_HOST_OS
createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
createProcessConcurrent p
| willOutput (P.std_out p) || willOutput (P.std_err p) =
@@ -255,6 +271,7 @@ createProcessConcurrent p
asyncProcessWaiter $
void $ tryIO $ P.waitForProcess h
return (toConcurrentProcessHandle r)
+#endif
-- | Wrapper around `System.Process.createProcess` that makes sure a process
-- is run in the foreground, with direct access to stdout and stderr.
@@ -274,6 +291,7 @@ fgProcess p = do
dropOutputLock
return (toConcurrentProcessHandle r)
+#ifndef mingw32_HOST_OS
bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
bgProcess p = do
(toouth, fromouth) <- pipe
@@ -297,6 +315,7 @@ bgProcess p = do
rediroutput ss h
| willOutput ss = P.UseHandle h
| otherwise = ss
+#endif
willOutput :: P.StdStream -> Bool
willOutput P.Inherit = True
@@ -473,19 +492,16 @@ bufferOutputSTM' h (OutputBuffer newbuf) = do
--
-- This will prevent it from being displayed in the usual way, so you'll
-- need to use `emitOutputBuffer` to display it yourself.
-outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM [(StdHandle, OutputBuffer)]
-outputBufferWaiterSTM selector = do
- bs <- forM hs $ \h -> do
+outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer)
+outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr
+ where
+ waitgetbuf h = do
let bv = bufferFor h
(selected, rest) <- selector <$> takeTMVar bv
+ when (selected == OutputBuffer [])
+ retry
putTMVar bv rest
- return selected
- if all (== OutputBuffer []) bs
- then retry
- else do
- return (zip hs bs)
- where
- hs = [StdOut, StdErr]
+ return (h, selected)
waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)
waitAnyBuffer b = (b, OutputBuffer [])