diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +concurrent-output (1.7.5) unstable; urgency=medium + + * createProcessConcurrent and System.Process.Concurrent are + now available on Windows. + + -- Joey Hess Sun, 01 May 2016 19:40:38 -0400 + concurrent-output (1.7.4) unstable; urgency=medium * Update process dep to allow 1.4. diff --git a/System/Console/Concurrent/Internal.hs b/System/Console/Concurrent/Internal.hs --- a/System/Console/Concurrent/Internal.hs +++ b/System/Console/Concurrent/Internal.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -O2 #-} +{- Building this module with -O0 causes streams not to fuse and too much + - memory to be used. -} -- | -- Copyright: 2015 Joey Hess @@ -12,9 +14,6 @@ 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 @@ -258,7 +257,6 @@ -- 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) = @@ -271,7 +269,6 @@ 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. @@ -293,31 +290,33 @@ 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 - (toerrh, fromerrh) <- pipe let p' = p - { P.std_out = rediroutput (P.std_out p) toouth - , P.std_err = rediroutput (P.std_err p) toerrh + { P.std_out = rediroutput (P.std_out p) + , P.std_err = rediroutput (P.std_err p) } registerOutputThread - r@(_, _, _, h) <- P.createProcess p' + (stdin_h, stdout_h, stderr_h, h) <- P.createProcess p' `onException` unregisterOutputThread + let r = + ( stdin_h + , mungeret (P.std_out p) stdout_h + , mungeret (P.std_err p) stderr_h + , h + ) asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h - outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth - errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh + outbuf <- setupOutputBuffer StdOut stdout_h + errbuf <- setupOutputBuffer StdErr stderr_h void $ async $ bufferWriter [outbuf, errbuf] return (toConcurrentProcessHandle r) where - pipe = do - (from, to) <- createPipe - (,) <$> fdToHandle to <*> fdToHandle from - rediroutput ss h - | willOutput ss = P.UseHandle h + rediroutput ss + | willOutput ss = P.CreatePipe | otherwise = ss -#endif + mungeret ss mh + | willOutput ss = Nothing + | otherwise = mh willOutput :: P.StdStream -> Bool willOutput P.Inherit = True @@ -350,32 +349,31 @@ data BufSig = BufSig -setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) -setupOutputBuffer h toh ss fromh = do - hClose toh +setupOutputBuffer :: StdHandle -> Maybe Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) +setupOutputBuffer h fromh = do buf <- newMVar (OutputBuffer []) bufsig <- atomically newEmptyTMVar bufend <- atomically newEmptyTMVar - void $ async $ outputDrainer ss fromh buf bufsig bufend + void $ async $ outputDrainer fromh buf bufsig bufend return (h, buf, bufsig, bufend) -- Drain output from the handle, and buffer it. -outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () -outputDrainer ss fromh buf bufsig bufend - | willOutput ss = go - | otherwise = atend +outputDrainer :: Maybe Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () +outputDrainer mfromh buf bufsig bufend = case mfromh of + Nothing -> atend + Just fromh -> go fromh where - go = do + go fromh = do t <- T.hGetChunk fromh if T.null t - then atend + then do + atend + hClose fromh else do modifyMVar_ buf $ addOutputBuffer (Output t) changed - go - atend = do - atomically $ putTMVar bufend AtEnd - hClose fromh + go fromh + atend = atomically $ putTMVar bufend AtEnd changed = atomically $ do void $ tryTakeTMVar bufsig putTMVar bufsig BufSig diff --git a/System/Console/Regions.hs b/System/Console/Regions.hs --- a/System/Console/Regions.hs +++ b/System/Console/Regions.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -O2 #-} +{- This module does a lot of calculation that can be expensive, so optimise + - it well -} -- | -- Copyright: 2015 Joey Hess diff --git a/System/Process/Concurrent.hs b/System/Process/Concurrent.hs --- a/System/Process/Concurrent.hs +++ b/System/Process/Concurrent.hs @@ -5,8 +5,6 @@ -- The functions exported by this module are intended to be drop-in -- replacements for those from System.Process, when converting a whole -- program to use System.Console.Concurrent. --- --- Not currently available on Windows. module System.Process.Concurrent where diff --git a/concurrent-output.cabal b/concurrent-output.cabal --- a/concurrent-output.cabal +++ b/concurrent-output.cabal @@ -1,5 +1,5 @@ Name: concurrent-output -Version: 1.7.4 +Version: 1.7.5 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess @@ -44,6 +44,7 @@ System.Console.Concurrent System.Console.Concurrent.Internal System.Console.Regions + System.Process.Concurrent Other-Modules: Utility.Monad Utility.Data @@ -51,7 +52,6 @@ if (! os(Windows)) Build-Depends: unix (>= 2.7.0 && < 2.8.0) - Exposed-Modules: System.Process.Concurrent source-repository head type: git