diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,20 +1,9 @@ import Distribution.Simple import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) import Distribution.Simple.Program -import System.Cmd import System.Directory import System.Exit +import System.Process main = copyFile "debian/changelog" "changelog" >> - defaultMainWithHooks simpleUserHooks { - postBuild = - \ _ _ _ lbi -> - case buildDir lbi of - "dist-ghc/build" -> return () - _ -> runTestScript lbi - , runTests = \ _ _ _ lbi -> runTestScript lbi - } - -runTestScript lbi = - system (buildDir lbi ++ "/tests/tests") >>= \ code -> - if code == ExitSuccess then return () else error "unit test failure" + defaultMainWithHooks simpleUserHooks diff --git a/System/Process/Progress.hs b/System/Process/Progress.hs --- a/System/Process/Progress.hs +++ b/System/Process/Progress.hs @@ -3,15 +3,11 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.Progress - ( module System.Process.Read.Chunks + ( module System.Process.Read.Convenience , module System.Process.Read.Compat , module System.Process.Read.Monad - , module System.Process.Read.Verbosity - , module System.Process.Read.Convenience ) where -import System.Process.Read.Chunks import System.Process.Read.Convenience import System.Process.Read.Compat import System.Process.Read.Monad -import System.Process.Read.Verbosity diff --git a/System/Process/Read/Chunks.hs b/System/Process/Read/Chunks.hs deleted file mode 100644 --- a/System/Process/Read/Chunks.hs +++ /dev/null @@ -1,294 +0,0 @@ --- | The 'readProcessChunks' function is a process reader that returns --- a list (stream) of 'Output', which represent chunks of text read --- from 'Stdout', 'Stderr', a 'Result' code, or an 'Exception'. This --- has the advantage of preserving the order in which these things --- appeared. The 'foldOutput', 'foldOutputsL', and 'foldOutputsR' --- functions can be used to process the output stream. The output --- text can be any 'NonBlocking' instance, which needs to be implemented --- using a non-blocking read function like 'B.hGetSome'. - -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances #-} -module System.Process.Read.Chunks ( - NonBlocking(..), - Output(..), - foldOutput, - foldOutputsL, - foldOutputsR, - readProcessChunks, - readProcessChunks' - ) where - -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO, threadDelay, MVar, newEmptyMVar, putMVar, takeMVar) -import Control.DeepSeq (NFData) -import Control.Exception as E (onException, catch, mask, try, throwIO, SomeException) -import Control.Monad (unless) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ListLike (ListLike(..), ListLikeIO(..)) -import Data.Word (Word8) -import qualified GHC.IO.Exception as E -import GHC.IO.Exception (IOErrorType(ResourceVanished), IOException(ioe_type)) -import Prelude hiding (null, length, rem) -import qualified Prelude -import System.Exit (ExitCode) -import System.IO hiding (hPutStr, hGetContents) -import System.IO.Error (mkIOError) -import System.Process.Read (ListLikePlus(..)) -import System.IO.Unsafe (unsafeInterleaveIO) -import System.Process (CreateProcess(..), StdStream(CreatePipe), ProcessHandle, - createProcess, waitForProcess, terminateProcess) - --- | This lets us use deepseq's force on the stream of data returned --- by the process-progress functions. -instance NFData ExitCode - --- | Class of types which can also be used by 'System.Process.Read.readProcessChunks'. -class ListLikePlus a c => NonBlocking a c where - hGetSome :: Handle -> LengthType a -> IO a - toChunks :: a -> [a] - -data Output a = Stdout a | Stderr a | Result ExitCode | Exception IOError deriving (Eq, Show) - --- | A fold function for the Output type, dispatches the value --- depending on the constructor. -foldOutput :: ListLikePlus a c => - (ExitCode -> b) - -> (a -> b) - -> (a -> b) - -> (IOError -> b) - -> Output a - -> b -foldOutput codefn _ _ _ (Result code) = codefn code -foldOutput _ outfn _ _ (Stdout out) = outfn out -foldOutput _ _ errfn _ (Stderr err) = errfn err -foldOutput _ _ _ exnfn (Exception exn) = exnfn exn - -foldOutputsL :: ListLikePlus a c => - (b -> ExitCode -> b) - -> (b -> a -> b) - -> (b -> a -> b) - -> (b -> IOError -> b) - -> b - -> [Output a] - -> b -foldOutputsL _ _ _ _ result [] = result -foldOutputsL codefn outfn errfn exnfn result (x : xs) = - let result' = foldOutput (codefn result) (outfn result) (errfn result) (exnfn result) x in - foldOutputsL codefn outfn errfn exnfn result' xs - -- Pretty sure this is equivalent: - -- foldl (\ r x -> foldOutput (codefn r) (outfn r) (errfn r) (exnfn r) x) result xs - -foldOutputsR :: forall a b c. ListLikePlus a c => - (b -> ExitCode -> b) - -> (b -> a -> b) - -> (b -> a -> b) - -> (b -> IOError -> b) - -> b - -> [Output a] - -> b -foldOutputsR _ _ _ _ result [] = result -foldOutputsR codefn outfn errfn exnfn result (x : xs) = - let result' = foldOutputsR codefn outfn errfn exnfn result xs in - foldOutput (codefn result') (outfn result') (errfn result') (exnfn result') x - -- foldr (\ x r -> foldOutput (codefn r) (outfn r) (errfn r) (exnfn r) x) result xs - --- | This is a process runner which (at the cost of a busy loop) gives --- you the chunks of text read from stdout and stderr interleaved in --- the order they were written, along with any ResourceVanished --- exxception that might occur. Its interface is similar to --- 'System.Process.Read.readModifiedProcessWith', though the --- implementation is somewhat alarming. -readProcessChunks :: (NonBlocking a c) => - CreateProcess - -> a - -> IO [Output a] -readProcessChunks p input = mask $ \ restore -> do - (Just inh, Just outh, Just errh, pid) <- - createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) - - binary input [inh, outh, errh] - - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - - waitOut <- forkWait $ elements pid (Just outh) (Just errh) - - -- now write and flush any input - (do unless (null input) (hPutStr inh input >> hFlush inh) - hClose inh) `E.catch` resourceVanished (\ _e -> return ()) - - -- wait on the output - waitOut - --- | Take the info returned by 'createProcess' and gather and return --- the stdout and stderr of the process. -elements :: NonBlocking a c => ProcessHandle -> Maybe Handle -> Maybe Handle -> IO [Output a] -elements pid outh errh = - do case (outh, errh) of - (Nothing, Nothing) -> - -- EOF on both output descriptors, get exit code. It can be - -- argued that the result will always contain exactly one exit - -- code if traversed to its end, because the only case of - -- 'elements' that does not recurse is the one that adds a Result, - -- and there is nowhere else where a Result is added. However, - -- the process doing the traversing may die before that end is - -- reached. - do result <- waitForProcess pid - return [Result result] - _ -> - -- The available output has been processed, send input and read - -- from the ready handles - do (outh', errh', elems') <- ready uSecs outh errh - more <- unsafeInterleaveIO (elements pid outh' errh') - return $ elems' ++ more - -data Readyness = Ready | Unready | Closed - -hReady' :: Handle -> IO Readyness -hReady' h = - -- This check is necessary because if we run hReady on a closed - -- handle it will keep giving us EOF exceptions. - hIsClosed h >>= checkReady - where - checkReady True = return Closed - checkReady False = - (hReady h >>= (\ flag -> return (if flag then Ready else Unready))) - `catch` endOfFile (\ _ -> return Closed) - --- | Wait until at least one handle is ready and then read output. If --- none of the output descriptors are ready for reading the function --- sleeps and tries again. -ready :: (NonBlocking a c) => - Int -> Maybe Handle -> Maybe Handle - -> IO (Maybe Handle, Maybe Handle, [Output a]) -ready waitUSecs outh errh = - do - outReady <- maybe (return Closed) hReady' outh - errReady <- maybe (return Closed) hReady' errh - case (outReady, errReady) of - (Closed, Closed) -> - return (Nothing, Nothing, []) - -- Input handle closed and there are no ready output handles, - -- wait a bit - (Unready, Unready) -> - do threadDelay waitUSecs - ready (min maxUSecs (2 * waitUSecs)) outh errh - _ -> - -- One or both output handles are ready, try to read from - -- them. If (out1 ++ out2) is an empty list we know that - -- we have reached EOF on both descriptors, because at - -- least one was ready and nextOut only returns [] for a - -- ready file descriptor on EOF. - do (errh', out1) <- nextOut errh errReady Stderr - (outh', out2) <- nextOut outh outReady Stdout - return (outh', errh', out1 ++ out2) - --- | Return the next output element and the updated handle from a --- handle which is assumed ready. If the handle is closed or unready, --- or we reach end of file an empty list of outputs is returned. -nextOut :: NonBlocking a c => Maybe Handle -> Readyness -> (a -> Output a) -> IO (Maybe Handle, [Output a]) -nextOut Nothing _ _ = return (Nothing, []) -nextOut (Just h) Ready constructor = -- Perform a read - do -- We can call hGetSome because we know this handle is ready for reading. - a <- hGetSome h (fromIntegral bufSize) - case length a of - -- A zero length read, unlike a zero length write, always - -- means EOF. - 0 -> do hClose h - return (Nothing, []) - -- Got some output - _n -> return (Just h, [constructor a]) -nextOut h _ _ = return (h, []) -- Handle is closed or not ready - -endOfFile :: (IOError -> IO a) -> IOError -> IO a -endOfFile eeof e = if E.ioe_type e == E.EOF then eeof e else ioError e - -bufSize :: Int -bufSize = 4096 -- maximum chunk size -uSecs :: Int -uSecs = 8 -- minimum wait time, doubles each time nothing is ready -maxUSecs :: Int -maxUSecs = 100000 -- maximum wait time (microseconds) - --- | A test version of readProcessChunks. --- Pipes code here: http://hpaste.org/76631 -readProcessChunks' :: (NonBlocking a c) => - CreateProcess - -> a - -> IO [Output a] -readProcessChunks' p input = mask $ \ restore -> do - (Just inh, Just outh, Just errh, pid) <- - createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) - - binary input [inh, outh, errh] - - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - - waitOut <- forkWait $ elements' pid outh errh - - -- now write and flush any input - (do unless (null input) (hPutStr inh input >> hFlush inh) - hClose inh) `catch` resourceVanished (\ _e -> return ()) - - -- wait on the output - waitOut - --- | An idea for a replacement of elements -elements' :: forall a c. NonBlocking a c => ProcessHandle -> Handle -> Handle -> IO [Output a] -elements' pid outh errh = do - res <- newEmptyMVar - -- We use Exception EOF to indicate that we reached EOF on one - -- handle. This is not a value that could otherwise have been put - -- into the MVar. - _outtid <- forkIO $ hGetContents outh >>= mapM_ (\ c -> putMVar res (Stdout c)) . toChunks >> hClose outh >> putMVar res (Exception (mkIOError E.EOF "EOF" Nothing Nothing)) - _errtid <- forkIO $ hGetContents errh >>= mapM_ (\ c -> putMVar res (Stderr c)) . toChunks >> hClose errh >> putMVar res (Exception (mkIOError E.EOF "EOF" Nothing Nothing)) - takeChunks 0 res - where - takeChunks :: Int -> MVar (Output a) -> IO [Output a] - takeChunks 2 _ = waitForProcess pid >>= \ result -> return [Result result] - takeChunks closedCount res = takeMVar res >>= takeChunk closedCount res - takeChunk closedCount res (Exception _) = takeChunks (closedCount + 1) res - takeChunk closedCount res x = - do xs <- unsafeInterleaveIO $ takeChunks closedCount res - return (x : xs) - -forkWait :: IO a -> IO (IO a) -forkWait a = do - res <- newEmptyMVar - _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res - return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return) - --- | Wrapper for a process that provides a handler for the --- ResourceVanished exception. This is frequently an exception we --- wish to ignore, because many processes will deliberately exit --- before they have read all of their input. -resourceVanished :: (IOError -> IO a) -> IOError -> IO a -resourceVanished epipe e = if ioe_type e == ResourceVanished then epipe e else ioError e - -{- -proc' :: CmdSpec -> CreateProcess -proc' (RawCommand cmd args) = proc cmd args -proc' (ShellCommand cmd) = shell cmd --} - -{- Its not safe to read a bytestring chunk and then convert it to a string, the chunk - might end with part of a character. -instance NonBlocking String Char where - -- hGetNonBlocking n h = (toString . B.concat . L.toChunks) <$> L.hGetNonBlocking n h - hGetSome h n = toList <$> B.hGetSome h n - toChunks = error "toChunks" --} - -instance NonBlocking B.ByteString Word8 where - -- hGetNonBlocking = B.hGetNonBlocking - hGetSome = B.hGetSome - toChunks = (: []) - -instance NonBlocking L.ByteString Word8 where - -- hGetNonBlocking = L.hGetNonBlocking - hGetSome h n = (L.fromChunks . (: [])) <$> B.hGetSome h (fromIntegral n) - toChunks = Prelude.map (L.fromChunks . (: [])) . L.toChunks diff --git a/System/Process/Read/Compat.hs b/System/Process/Read/Compat.hs --- a/System/Process/Read/Compat.hs +++ b/System/Process/Read/Compat.hs @@ -10,9 +10,9 @@ import Data.Time (NominalDiffTime, getCurrentTime, diffUTCTime) import System.Exit (ExitCode(..)) import System.Process (CmdSpec(..), showCommandForUser) -import System.Process.Read.Chars (ListLikePlus) +import System.Process.Chunks (Chunk(..)) +import System.Process.ListLike (ListLikePlus) import System.Process.Read.Convenience (ePutStrLn, keepResult) -import System.Process.Read.Chunks (Output(..)) -- | Output a description of a command and then run it. echo :: CmdSpec -> IO () -> IO () @@ -21,7 +21,7 @@ -- | Extract the result code of an output stream, throw an error if -- there isn't exactly one of them. -oneResult :: ListLikePlus a c => [Output a] -> ExitCode +oneResult :: ListLikePlus a c => [Chunk a] -> ExitCode oneResult xs = case keepResult xs of [code] -> code diff --git a/System/Process/Read/Convenience.hs b/System/Process/Read/Convenience.hs --- a/System/Process/Read/Convenience.hs +++ b/System/Process/Read/Convenience.hs @@ -7,6 +7,7 @@ , isStderr , isOutput , isException + , isHandle -- * Filters , discardStdout , discardStderr @@ -54,7 +55,6 @@ ) where import Control.Exception (throw) -import Control.Monad (when) import Control.Monad.Trans (MonadIO, liftIO) import Data.ListLike (ListLike(empty, append, concat, span, tail, singleton, null), ListLikeIO(hPutStr)) import Data.Maybe (mapMaybe) @@ -62,68 +62,72 @@ import System.Exit (ExitCode(..), exitWith) import System.IO (stdout, stderr) import qualified System.IO as IO (hPutStr, hPutStrLn) -import System.Process.Read.Chars (ListLikePlus(..)) -import System.Process.Read.Chunks (NonBlocking(..), Output(..), foldOutput, foldOutputsR) -import System.Process.Read.Instances () +import System.Process (ProcessHandle) +import System.Process.ListLike (ListLikePlus(..)) +import System.Process.Chunks (Chunk(..), foldChunks, foldChunk, putDots) -isResult :: ListLikePlus a c => Output a -> Bool -isResult = foldOutput (const True) (const False) (const False) (const False) -isStdout :: ListLikePlus a c => Output a -> Bool -isStdout = foldOutput (const False) (const True) (const False) (const False) -isStderr :: ListLikePlus a c => Output a -> Bool -isStderr = foldOutput (const False) (const False) (const True) (const False) -isOutput :: ListLikePlus a c => Output a -> Bool -isOutput = foldOutput (const False) (const True) (const True) (const False) -isException :: ListLikePlus a c => Output a -> Bool -isException = foldOutput (const False) (const False) (const False) (const True) +isHandle :: ListLikePlus a c => Chunk a -> Bool +isHandle = foldChunk (const True) (const False) (const False) (const False) (const False) +isResult :: ListLikePlus a c => Chunk a -> Bool +isResult = foldChunk (const False) (const False) (const False) (const False) (const True) +isStdout :: ListLikePlus a c => Chunk a -> Bool +isStdout = foldChunk (const False) (const True) (const False) (const False) (const False) +isStderr :: ListLikePlus a c => Chunk a -> Bool +isStderr = foldChunk (const False) (const False) (const True) (const False) (const False) +isOutput :: ListLikePlus a c => Chunk a -> Bool +isOutput = foldChunk (const False) (const True) (const True) (const False) (const False) +isException :: ListLikePlus a c => Chunk a -> Bool +isException = foldChunk (const False) (const False) (const False) (const True) (const False) -toStdout :: ListLikePlus a c => Output a -> Output a -toStdout = foldOutput Result Stdout Stdout Exception -toStderr :: ListLikePlus a c => Output a -> Output a -toStderr = foldOutput Result Stderr Stderr Exception +toStdout :: ListLikePlus a c => Chunk a -> Chunk a +toStdout = foldChunk ProcessHandle Stdout Stdout Exception Result +toStderr :: ListLikePlus a c => Chunk a -> Chunk a +toStderr = foldChunk ProcessHandle Stderr Stderr Exception Result -mergeToStdout :: ListLikePlus a c => [Output a] -> [Output a] +mergeToStdout :: ListLikePlus a c => [Chunk a] -> [Chunk a] mergeToStdout = map toStdout -mergeToStderr :: ListLikePlus a c => [Output a] -> [Output a] +mergeToStderr :: ListLikePlus a c => [Chunk a] -> [Chunk a] mergeToStderr = map toStderr -discardStdout :: ListLikePlus a c => [Output a] -> [Output a] +discardStdout :: ListLikePlus a c => [Chunk a] -> [Chunk a] discardStdout = filter (not . isStdout) -discardStderr :: ListLikePlus a c => [Output a] -> [Output a] +discardStderr :: ListLikePlus a c => [Chunk a] -> [Chunk a] discardStderr = filter (not . isStderr) -discardOutput :: ListLikePlus a c => [Output a] -> [Output a] +discardOutput :: ListLikePlus a c => [Chunk a] -> [Chunk a] discardOutput = filter (\ x -> not (isStdout x || isStderr x)) -discardExceptions :: ListLikePlus a c => [Output a] -> [Output a] +discardExceptions :: ListLikePlus a c => [Chunk a] -> [Chunk a] discardExceptions = filter (not . isException) -discardResult :: ListLikePlus a c => [Output a] -> [Output a] +discardResult :: ListLikePlus a c => [Chunk a] -> [Chunk a] discardResult = filter (not . isResult) -keepStdout :: ListLikePlus a c => [Output a] -> [a] -keepStdout = mapMaybe $ foldOutput (const Nothing) Just (const Nothing) (const Nothing) -keepStderr :: ListLikePlus a c => [Output a] -> [a] -keepStderr = mapMaybe $ foldOutput (const Nothing) (const Nothing) Just (const Nothing) -keepOutput :: ListLikePlus a c => [Output a] -> [a] -keepOutput = mapMaybe $ foldOutput (const Nothing) Just Just (const Nothing) -keepExceptions :: ListLikePlus a c => [Output a] -> [IOError] -keepExceptions = mapMaybe $ foldOutput (const Nothing) (const Nothing) (const Nothing) Just -keepResult :: ListLikePlus a c => [Output a] -> [ExitCode] -keepResult = mapMaybe $ foldOutput Just (const Nothing) (const Nothing) (const Nothing) +keepStdout :: ListLikePlus a c => [Chunk a] -> [a] +keepStdout = mapMaybe $ foldChunk (const Nothing) Just (const Nothing) (const Nothing) (const Nothing) +keepStderr :: ListLikePlus a c => [Chunk a] -> [a] +keepStderr = mapMaybe $ foldChunk (const Nothing) (const Nothing) Just (const Nothing) (const Nothing) +keepOutput :: ListLikePlus a c => [Chunk a] -> [a] +keepOutput = mapMaybe $ foldChunk (const Nothing) Just Just (const Nothing) (const Nothing) +keepExceptions :: ListLikePlus a c => [Chunk a] -> [IOError] +keepExceptions = mapMaybe $ foldChunk (const Nothing) (const Nothing) (const Nothing) Just (const Nothing) +keepResult :: ListLikePlus a c => [Chunk a] -> [ExitCode] +keepResult = mapMaybe $ foldChunk (const Nothing) (const Nothing) (const Nothing) (const Nothing) Just -mapMaybeResult :: ListLikePlus a c => (ExitCode -> Maybe (Output a)) -> [Output a] -> [Output a] -mapMaybeResult f = mapMaybe (foldOutput f (Just . Stdout) (Just . Stderr) (Just . Exception)) -mapMaybeStdout :: ListLikePlus a c => (a -> Maybe (Output a)) -> [Output a] -> [Output a] -mapMaybeStdout f = mapMaybe (foldOutput (Just . Result) f (Just . Stderr) (Just . Exception)) -mapMaybeStderr :: ListLikePlus a c => (a -> Maybe (Output a)) -> [Output a] -> [Output a] -mapMaybeStderr f = mapMaybe (foldOutput (Just . Result) (Just . Stdout) f (Just . Exception)) -mapMaybeException :: ListLikePlus a c => (IOError -> Maybe (Output a)) -> [Output a] -> [Output a] -mapMaybeException f = mapMaybe (foldOutput (Just . Result) (Just . Stdout) (Just . Stderr) f) +mapMaybeResult :: ListLikePlus a c => (ExitCode -> Maybe (Chunk a)) -> [Chunk a] -> [Chunk a] +mapMaybeResult f = mapMaybe (foldChunk (Just . ProcessHandle) (Just . Stdout) (Just . Stderr) (Just . Exception) f) +mapMaybeStdout :: ListLikePlus a c => (a -> Maybe (Chunk a)) -> [Chunk a] -> [Chunk a] +mapMaybeStdout f = mapMaybe (foldChunk (Just . ProcessHandle) f (Just . Stderr) (Just . Exception) (Just . Result)) +mapMaybeStderr :: ListLikePlus a c => (a -> Maybe (Chunk a)) -> [Chunk a] -> [Chunk a] +mapMaybeStderr f = mapMaybe (foldChunk (Just . ProcessHandle) (Just . Stdout) f (Just . Exception) (Just . Result)) +mapMaybeException :: ListLikePlus a c => (IOError -> Maybe (Chunk a)) -> [Chunk a] -> [Chunk a] +mapMaybeException f = mapMaybe (foldChunk (Just . ProcessHandle) (Just . Stdout) (Just . Stderr) f (Just . Result)) -collectOutputs :: forall a c. ListLikePlus a c => [Output a] -> ([ExitCode], a, a, [IOError]) +collectOutputs :: forall a c. ListLikePlus a c => [Chunk a] -> ([ExitCode], a, a, [IOError]) collectOutputs xs = - foldOutputsR codefn outfn errfn exnfn result0 xs + foldChunks (\ r -> foldChunk (pidfn r) (outfn r) (errfn r) (exnfn r) (codefn r)) result0 xs where result0 :: ([ExitCode], a, a, [IOError]) result0 = ([], empty, empty, []) + pidfn :: ([ExitCode], a, a, [IOError]) -> ProcessHandle -> ([ExitCode], a, a, [IOError]) + pidfn (codes, outs, errs, exns) _ = (codes, outs, errs, exns) codefn :: ([ExitCode], a, a, [IOError]) -> ExitCode -> ([ExitCode], a, a, [IOError]) codefn (codes, outs, errs, exns) code = (code : codes, outs, errs, exns) outfn :: ([ExitCode], a, a, [IOError]) -> a -> ([ExitCode], a, a, [IOError]) @@ -145,86 +149,91 @@ eMessageLn :: MonadIO m => String -> a -> m a eMessageLn s x = ePutStrLn s >> return x -foldException :: ListLikePlus a c => (IOError -> IO (Output a)) -> [Output a] -> IO [Output a] -foldException exnfn = mapM (foldOutput (return . Result) (return . Stdout) (return . Stderr) exnfn) +foldException :: ListLikePlus a c => (IOError -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] +foldException exnfn = mapM (foldChunk (return . ProcessHandle) (return . Stdout) (return . Stderr) exnfn (return . Result)) -foldChars :: ListLikePlus a c => (a -> IO (Output a)) -> (a -> IO (Output a)) -> [Output a] -> IO [Output a] -foldChars outfn errfn = mapM (foldOutput (return . Result) outfn errfn (return . Exception)) +foldChars :: ListLikePlus a c => (a -> IO (Chunk a)) -> (a -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] +foldChars outfn errfn = mapM (foldChunk (return . ProcessHandle) outfn errfn (return . Exception)(return . Result)) -foldStdout :: ListLikePlus a c => (a -> IO (Output a)) -> [Output a] -> IO [Output a] +foldStdout :: ListLikePlus a c => (a -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] foldStdout outfn = foldChars outfn (return . Stderr) -foldStderr :: ListLikePlus a c => (a -> IO (Output a)) -> [Output a] -> IO [Output a] +foldStderr :: ListLikePlus a c => (a -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] foldStderr errfn = foldChars (return . Stdout) errfn -foldResult :: ListLikePlus a c => (ExitCode -> IO (Output a)) -> [Output a] -> IO [Output a] -foldResult codefn = mapM (foldOutput codefn (return . Stdout) (return . Stderr) (return . Exception)) +foldResult :: ListLikePlus a c => (ExitCode -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] +foldResult codefn = mapM (foldChunk (return . ProcessHandle) (return . Stdout) (return . Stderr) (return . Exception) codefn) -foldFailure :: ListLikePlus a c => (Int -> IO (Output a)) -> [Output a] -> IO [Output a] +foldFailure :: ListLikePlus a c => (Int -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] foldFailure failfn = foldResult codefn where codefn (ExitFailure n) = failfn n codefn x = return (Result x) -foldResult' :: ListLikePlus a c => ([Output a] -> ExitCode -> IO (Output a)) -> [Output a] -> IO [Output a] -foldResult' codefn outputs = mapM (foldOutput (codefn outputs) (return . Stdout) (return . Stderr) (return . Exception)) outputs +foldResult' :: ListLikePlus a c => ([Chunk a] -> ExitCode -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] +foldResult' codefn outputs = mapM (foldChunk (return . ProcessHandle) (return . Stdout) (return . Stderr) (return . Exception) (codefn outputs)) outputs -foldFailure' :: ListLikePlus a c => (Int -> IO (Output a)) -> [Output a] -> IO [Output a] +foldFailure' :: ListLikePlus a c => (Int -> IO (Chunk a)) -> [Chunk a] -> IO [Chunk a] foldFailure' failfn outputs = foldResult' codefn outputs - where codefn outputs (ExitFailure n) = failfn n + where codefn _outputs (ExitFailure n) = failfn n codefn _ x = return (Result x) -foldSuccess :: ListLikePlus a c => IO (Output a) -> [Output a] -> IO [Output a] +foldSuccess :: ListLikePlus a c => IO (Chunk a) -> [Chunk a] -> IO [Chunk a] foldSuccess successfn = foldResult codefn where codefn ExitSuccess = successfn codefn x = return (Result x) -doException :: ListLikePlus a c => [Output a] -> IO [Output a] +doException :: ListLikePlus a c => [Chunk a] -> IO [Chunk a] doException = foldException throw -doOutput :: ListLikePlus a c => [Output a] -> IO [Output a] +doOutput :: ListLikePlus a c => [Chunk a] -> IO [Chunk a] doOutput = foldChars (\ cs -> hPutStr stdout cs >> return (Stdout cs)) (\ cs -> hPutStr stderr cs >> return (Stderr cs)) -doStdout :: ListLikePlus a c => [Output a] -> IO [Output a] +doStdout :: ListLikePlus a c => [Chunk a] -> IO [Chunk a] doStdout = foldStdout (\ cs -> hPutStr stdout cs >> return (Stdout cs)) -doStderr :: ListLikePlus a c => [Output a] -> IO [Output a] +doStderr :: ListLikePlus a c => [Chunk a] -> IO [Chunk a] doStderr = foldStderr (\ cs -> hPutStr stderr cs >> return (Stderr cs)) -- | I don't see much use for this. -doExit :: ListLikePlus a c => [Output a] -> IO [Output a] +doExit :: ListLikePlus a c => [Chunk a] -> IO [Chunk a] doExit = foldResult (\ code -> exitWith code >> return (Result code)) -doAll :: ListLikePlus a c => [Output a] -> IO [Output a] -doAll = mapM (foldOutput (\ code -> exitWith code >> return (Result code)) +doAll :: ListLikePlus a c => [Chunk a] -> IO [Chunk a] +doAll = mapM (foldChunk (\ pid -> return (ProcessHandle pid)) (\ cs -> hPutStr stdout cs >> return (Stdout cs)) (\ cs -> hPutStr stderr cs >> return (Stderr cs)) - throw) + throw + (\ code -> return (Result code))) -dots :: forall a c. NonBlocking a c => LengthType a -> (LengthType a -> IO ()) -> [Output a] -> IO [Output a] +dots :: (ListLikePlus a c, c ~ Char) => Int -> {- (Int -> IO ()) -> -} [Chunk a] -> IO [Chunk a] +dots charsPerDot chunks = putDots charsPerDot '.' chunks +{- +dots :: forall a c. ListLikePlus a c => Int -> (Int -> IO ()) -> [Chunk a] -> IO [Chunk a] dots charsPerDot nDots outputs = nDots 1 >> dots' 0 outputs >>= eMessage "\n" where dots' _ [] = nDots 1 >> return [] dots' rem (x : xs) = - do let (count', rem') = divMod (rem + foldOutput (const 0) length' length' (const 0) x) charsPerDot + do let (count', rem') = divMod (rem + foldChunk (const 0) length length (const 0) (const 0) x) charsPerDot when (count' > 0) (nDots count') xs' <- dots' rem' xs return (x : xs') +-} -- | Output the stream with a prefix added at the beginning of each -- line of stdout and stderr. -prefixed :: forall a c. (Enum c, ListLikePlus a c) => a -> a -> [Output a] -> IO [Output a] +prefixed :: forall a c. (Enum c, ListLikePlus a c) => a -> a -> [Chunk a] -> IO [Chunk a] prefixed opre epre output = mapM (\ (old, new) -> doOutput [new] >> return old) (prefixes opre epre output) -- | Return the original stream of outputs zipped with one that has -- had prefixes for stdout and stderr inserted. For the prefixed -- stream only, apply @map snd@. -prefixes :: forall a c. (Enum c, ListLikePlus a c) => a -> a -> [Output a] -> [(Output a, Output a)] +prefixes :: forall a c. (Enum c, ListLikePlus a c) => a -> a -> [Chunk a] -> [(Chunk a, Chunk a)] prefixes opre epre output = loop True output where - loop :: (Enum c, ListLike a c) => Bool -> [Output a] -> [(Output a, Output a)] + loop :: (Enum c, ListLike a c) => Bool -> [Chunk a] -> [(Chunk a, Chunk a)] loop _ [] = [] loop bol (x@(Stdout s) : xs) = let (s', bol') = step bol opre s in (x, Stdout s') : loop bol' xs loop bol (x@(Stderr s) : xs) = let (s', bol') = step bol epre s in (x, Stderr s') : loop bol' xs diff --git a/System/Process/Read/Monad.hs b/System/Process/Read/Monad.hs --- a/System/Process/Read/Monad.hs +++ b/System/Process/Read/Monad.hs @@ -21,13 +21,15 @@ import Control.Monad (when, unless) import Control.Monad.State (StateT(runStateT), get, put) import Control.Monad.Trans (MonadIO, liftIO) +import Data.Char (ord) import qualified Data.ListLike as P +import Data.Word (Word8) import Prelude hiding (print) import System.Exit (ExitCode(ExitFailure)) -import System.IO (hPutStrLn, hPutStr, stderr) +import System.IO (hPutStrLn, stderr) import System.Process (CreateProcess(cmdspec), CmdSpec(RawCommand, ShellCommand), showCommandForUser) -import qualified System.Process.Read.Chars as P -import qualified System.Process.Read.Chunks as P +import qualified System.Process.Chunks as P +import qualified System.Process.ListLike as P import qualified System.Process.Read.Convenience as P -- | The state we need when running processes @@ -76,21 +78,24 @@ setPrefixes :: (P.ListLikePlus s c, MonadIO m) => Maybe (s, s) -> RunT s m () setPrefixes x = modifyRunState (\ s -> s {prefixes = x}) -runProcessM :: forall s c m. (P.NonBlocking s c, Enum c, MonadIO m) => CreateProcess -> s -> RunT s m [P.Output s] +runProcessM :: forall s c m. (P.ListLikePlus s c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> s -> RunT s m [P.Chunk s] runProcessM p input = do s <- get liftIO $ do when (trace s) (hPutStrLn stderr ("-> " ++ showCommand (cmdspec p))) - (out1 :: [P.Output s]) <- P.readProcessChunks p input - (out2 :: [P.Output s]) <- if cpd s > 0 then P.dots (fromIntegral (cpd s)) (\ n -> hPutStr stderr (replicate (fromIntegral n) '.')) out1 else return out1 - (out3 :: [P.Output s]) <- if echo s then doOutput (prefixes s) out2 else return out2 - (out5 :: [P.Output s]) <- if failExit s then P.foldFailure' (\ n -> doOutput (exnPrefixes s) out3 >> error (showCommand (cmdspec p) ++ " -> ExitFailure " ++ show n)) out3 else return out3 - (out6 :: [P.Output s]) <- (if trace s then P.foldResult (\ ec -> hPutStrLn stderr ("<- " ++ showCommand (cmdspec p) ++ ": " ++ show ec) >> return (P.Result ec)) else return) out5 - (out7 :: [P.Output s]) <- (if failEcho s then P.foldFailure (\ n -> unless (trace s) (hPutStrLn stderr ("<- " ++ showCommand (cmdspec p) ++ ": " ++ show (ExitFailure n))) >> + (out1 :: [P.Chunk s]) <- P.readProcessChunks p input + (out2 :: [P.Chunk s]) <- if cpd s > 0 then P.putDots (cpd s) dot out1 else return out1 + (out3 :: [P.Chunk s]) <- if echo s then doOutput (prefixes s) out2 else return out2 + (out5 :: [P.Chunk s]) <- if failExit s then P.foldFailure' (\ n -> doOutput (exnPrefixes s) out3 >> error (showCommand (cmdspec p) ++ " -> ExitFailure " ++ show n)) out3 else return out3 + (out6 :: [P.Chunk s]) <- (if trace s then P.foldResult (\ ec -> hPutStrLn stderr ("<- " ++ showCommand (cmdspec p) ++ ": " ++ show ec) >> return (P.Result ec)) else return) out5 + (out7 :: [P.Chunk s]) <- (if failEcho s then P.foldFailure (\ n -> unless (trace s) (hPutStrLn stderr ("<- " ++ showCommand (cmdspec p) ++ ": " ++ show (ExitFailure n))) >> doOutput (prefixes s) out5 >> return (P.Result (ExitFailure n))) else return) out6 return out7 + where + dot :: Word8 + dot = fromIntegral (ord '.') -doOutput :: (P.ListLikePlus a c, Enum c) => Maybe (a, a) -> [P.Output a] -> IO [P.Output a] +doOutput :: (P.ListLikePlus a c, Enum c) => Maybe (a, a) -> [P.Chunk a] -> IO [P.Chunk a] doOutput prefixes out = maybe (P.doOutput out) (\ (sout, serr) -> P.prefixed sout serr out) prefixes >> return out -- doOutput prefixes out = P.doOutput out >> return out @@ -113,56 +118,56 @@ e = echoOnFailure True >> setPrefixes (Just (P.fromList (map (toEnum . fromEnum) " 1> "), P.fromList (map (toEnum . fromEnum) " 2> "))) >> exceptionOnFailure True >> echoOutput False -- | Run silently -runProcessS :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessS :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessS p input = withRunState defaultRunState (s >> runProcessM p input) -- | Command line trace only. -runProcessQ :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessQ :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessQ p input = withRunState defaultRunState (runProcessM p input) -- | Dot output -runProcessD :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessD :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessD p input = withRunState defaultRunState (c >> d >> runProcessM p input) -- | Echo output -runProcessV :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessV :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessV p input = withRunState defaultRunState (c >> v >> runProcessM p input) -- | Exception on failure -runProcessSF :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessSF :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessSF p input = withRunState defaultRunState (s >> f >> runProcessM p input) -runProcessQF :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessQF :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessQF p input = withRunState defaultRunState (c >> f >> runProcessM p input) -- | Dot output and exception on failure -runProcessDF :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessDF :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessDF p input = withRunState defaultRunState (c >> d >> f >> runProcessM p input) -- | Echo output and exception on failure -runProcessVF :: (P.NonBlocking a c, Enum c, MonadIO m) => CreateProcess -> a -> m [P.Output a] +runProcessVF :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => CreateProcess -> a -> m [P.Chunk a] runProcessVF p input = withRunState defaultRunState (c >> v >> f >> runProcessM p input) -- | Exception and echo on failure -runProcessSE :: (P.NonBlocking a c, Enum c, MonadIO m) => Maybe (a, a) -> CreateProcess -> a -> m [P.Output a] +runProcessSE :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => Maybe (a, a) -> CreateProcess -> a -> m [P.Chunk a] runProcessSE prefixes p input = withRunState (defaultRunState {exnPrefixes = prefixes}) (s >> e >> runProcessM p input) -- | Exception and echo on failure -runProcessQE :: (P.NonBlocking a c, Enum c, MonadIO m) => Maybe (a, a) -> CreateProcess -> a -> m [P.Output a] +runProcessQE :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => Maybe (a, a) -> CreateProcess -> a -> m [P.Chunk a] runProcessQE prefixes p input = withRunState (defaultRunState {exnPrefixes = prefixes}) (c >> e >> runProcessM p input) -- | Dot output, exception on failure, echo on failure. Note that -- runProcessVE isn't a useful option, you get the output twice. VF -- makes more sense. -runProcessDE :: (P.NonBlocking a c, Enum c, MonadIO m) => Maybe (a, a) -> CreateProcess -> a -> m [P.Output a] +runProcessDE :: (P.ListLikePlus a c, Enum c, MonadIO m, c ~ Word8) => Maybe (a, a) -> CreateProcess -> a -> m [P.Chunk a] runProcessDE prefixes p input = withRunState (defaultRunState {exnPrefixes = prefixes}) (c >> d >> e >> runProcessM p input) diff --git a/System/Process/Read/Verbosity.hs b/System/Process/Read/Verbosity.hs deleted file mode 100644 --- a/System/Process/Read/Verbosity.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} -module System.Process.Read.Verbosity - ( quieter - , noisier - , withModifiedVerbosity - , defaultVerbosity - , verbosity - -- * Process functions controlled by the VERBOSITY level. - , runProcess - , runProcessF - -- * Output functions controlled by the VERBOSITY level. We want these - -- to output whenever the runProcess functions are not silent, and we want - -- them to output at the first silent output setting, but then to stop. - , qPutStr - , qPutStrLn - , qMessage - , qMessageLn - , qBracket - ) where - -import Control.Monad (when) -import Control.Monad.Trans (MonadIO, liftIO) -import System.Process (CreateProcess) -import System.Posix.EnvPlus (getEnv, modifyEnv) -import System.Process.Read.Chunks (Output, NonBlocking) -import System.Process.Read.Convenience (ePutStr, ePutStrLn) -import System.Process.Read.Monad (runProcessS, runProcessQ, runProcessD, runProcessV, - runProcessSF, {-runProcessQF, runProcessDF,-} runProcessVF, - runProcessSE, runProcessQE, runProcessDE) - -quieter :: MonadIO m => Int -> m a -> m a -quieter n action = withModifiedVerbosity (\ v -> v - n) action -noisier :: MonadIO m => Int -> m a -> m a -noisier n action = withModifiedVerbosity (\ v -> v + n) action - -withModifiedVerbosity :: MonadIO m => (Int -> Int) -> m a -> m a -withModifiedVerbosity f action = - verbosity >>= \ v -> - liftIO (modifyEnv "VERBOSITY" (const (Just (show (f v))))) >> - -- ePutStr ("[" ++ show (f v) ++ "]") >> - action >>= \ result -> - -- ePutStr ("[" ++ show v ++ "]") >> - liftIO (modifyEnv "VERBOSITY" (const (Just (show v)))) >> - return result - -defaultVerbosity :: Int -defaultVerbosity = 1 - -verbosity :: MonadIO m => m Int -verbosity = liftIO $ getEnv "VERBOSITY" >>= return . maybe 1 read - --- | Select from the runProcess* functions in Monad based on a verbosity level. -runProcess :: (NonBlocking s c, Enum c, MonadIO m) => CreateProcess -> s -> m [Output s] -runProcess p input = liftIO $ - verbosity >>= \ v -> - case v of - _ | v <= 0 -> runProcessS p input - 1 -> runProcessQ p input - 2 -> runProcessD p input - _ -> runProcessV p input - --- | A version of 'runProcess' that throws an exception on failure. -runProcessF :: (NonBlocking s c, Enum c, MonadIO m) => Maybe (s, s) -> CreateProcess -> s -> m [Output s] -runProcessF prefixes p input = liftIO $ - verbosity >>= \ v -> - case v of - _ | v < 0 -> runProcessSF p input - 0 -> runProcessSE prefixes p input - 1 -> runProcessQE prefixes p input - 2 -> runProcessDE prefixes p input - _ -> runProcessVF p input - -qPutStrLn :: MonadIO m => String -> m () -qPutStrLn s = verbosity >>= \ v -> when (v > 0) (ePutStrLn s) - -qPutStr :: MonadIO m => String -> m () -qPutStr s = verbosity >>= \ v -> when (v > 0) (ePutStr s) - -qMessage :: MonadIO m => String -> a -> m a -qMessage s x = qPutStr s >> return x - -qMessageLn :: MonadIO m => String -> a -> m a -qMessageLn s x = qPutStrLn s >> return x - -qBracket :: MonadIO m => String -> m a -> m a -qBracket message action = do - v <- verbosity - case v of - n | n < 1 -> action - 1 -> do - qPutStr (message ++ "...") - result <- quieter 1 action - qPutStrLn "done." - return result - n -> do - qPutStrLn message - result <- quieter 1 action - qPutStrLn (message ++ "...done.") - return result diff --git a/Tests/Main.hs b/Tests/Main.hs deleted file mode 100644 --- a/Tests/Main.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Main where - -import qualified Codec.Binary.UTF8.String as UTF8 -import qualified Data.ByteString.Lazy as L -import Data.ListLike (ListLike(concat)) -import Prelude hiding (length, concat) -import System.Exit -import System.Posix.Files (getFileStatus, fileMode, setFileMode, unionFileModes, ownerExecuteMode, groupExecuteMode, otherExecuteMode) -import System.Process (proc, shell) -import System.Process.Progress (Output(..), readProcessChunks, keepStdout, discardStdout, collectOutputs) -import System.Process.Read.Chunks (readProcessChunks') -import Test.HUnit hiding (path) - -main :: IO () -main = - do chmod "Tests/Test1.hs" - chmod "Tests/Test2.hs" - chmod "Tests/Test4.hs" - (c,st) <- runTestText putTextToShowS test1 -- (TestList (versionTests ++ sourcesListTests ++ dependencyTests ++ changesTests)) - putStrLn (st "") - case (failures c) + (errors c) of - 0 -> return () - _ -> exitFailure - -encode :: String -> L.ByteString -encode = L.pack . UTF8.encode - -chmod :: FilePath -> IO () -chmod path = - getFileStatus "Tests/Test1.hs" >>= \ status -> - setFileMode path (foldr unionFileModes (fileMode status) [ownerExecuteMode, groupExecuteMode, otherExecuteMode]) - -test1 :: Test -test1 = - TestLabel "test1" - (TestList - [ TestLabel "pnmfile3" $ - TestCase (do jpg <- L.readFile "Tests/penguin.jpg" - pnm <- readProcessChunks (proc "djpeg" []) jpg >>= return . concat . keepStdout :: IO L.ByteString - info <- readProcessChunks (proc "pnmfile" []) pnm >>= return . concat . keepStdout :: IO L.ByteString - assertEqual "pnmfile3" (encode "stdin:\tPPM raw, 96 by 96 maxval 255\n") info) - , test2 - , TestLabel "readProcessChunks stdout stderr" $ - TestCase (do out <- readProcessChunks (shell "yes | head -10 | while read i; do echo stdout; echo stderr 1>&2; done") L.empty - let result = collectOutputs out - assertEqual "readProcessChunks stdout stderr" ([ExitSuccess], encode "stdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\n", encode "stderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\n", []) result) - , test3 - , TestLabel "readProcessChunks' stdout stderr" $ - TestCase (do out <- readProcessChunks' (shell "yes | head -10 | while read i; do echo stdout; echo stderr 1>&2; done") L.empty - let result = collectOutputs out - assertEqual "readProcessChunks' stdout stderr" ([ExitSuccess], encode "stdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\nstdout\n", encode "stderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\nstderr\n", []) result) -{- - , TestLabel "timed dot test" $ - TestCase (do output <- readModifiedProcess id (ShellCommand "Tests/Test2.hs") "" >>= return . take 10 - assertEqual "timed dot test" ".........." output) --} - ]) - -test2 :: Test -test2 = TestLabel "readProcessChunks gzip" $ - TestCase (do result <- readProcessChunks (shell "gzip -v -f < Tests/penguin.jpg") L.empty - assertEqual "readProcessChunks gzip" [Stderr (encode " 2.0%\n"),Result ExitSuccess] (discardStdout result)) - -test3 :: Test -test3 = TestLabel "readProcessChunks' gzip'" $ - TestCase (do result <- readProcessChunks' (shell "gzip -v -f < Tests/penguin.jpg") L.empty - assertEqual "readProcessChunks' gzip" [Stderr (encode " 2.0%\n"),Result ExitSuccess] (discardStdout result)) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,37 @@ +haskell-process-progress (0.14) unstable; urgency=low + + * Remove Tests, they were all duplicates of the ones in + process-listlike. + + -- David Fox Tue, 02 Sep 2014 08:50:04 -0700 + +haskell-process-progress (0.13) unstable; urgency=low + + * Finish conversion to new readInterleaved code. + + -- David Fox Wed, 27 Aug 2014 12:14:17 -0700 + +haskell-process-progress (0.12) unstable; urgency=low + + * Move System.Process.Read.Verbosity into a separate package. + + -- David Fox Sun, 24 Aug 2014 14:10:20 -0700 + +haskell-process-progress (0.11) unstable; urgency=low + + * Support interleaving of output from a list of file handles + * Use the simpler MVar based version of the interleaved reader + + -- David Fox Mon, 28 Jul 2014 23:07:53 -0700 + +haskell-process-progress (0.10) unstable; urgency=low + + * When DEBUG_VERBOSITY environment variable is set, prefix each string + output by vPutStr of vPutStrLn with the current verbosity level, and + don't suppress any output. + + -- David Fox Fri, 30 May 2014 13:36:08 -0700 + haskell-process-progress (0.9) unstable; urgency=low * Now $VERBOSITY<=0 means the qPutStr and qPutStrLn functions don't diff --git a/process-progress.cabal b/process-progress.cabal --- a/process-progress.cabal +++ b/process-progress.cabal @@ -1,5 +1,5 @@ Name: process-progress -Version: 0.9 +Version: 0.14 Synopsis: Run a process and do reportsing on its progress. Description: Function to run a process and wrappers to provide different types of feedback while it executes. @@ -14,7 +14,7 @@ source-repository head Type: darcs - Location: http://src.seereason.com/debian-tools/process-progress + Location: http://src.seereason.com/process-progress Library ghc-options: -Wall -O2 -threaded @@ -22,16 +22,14 @@ Exposed-modules: System.Posix.EnvPlus System.Process.Progress - System.Process.Read.Chunks System.Process.Read.Compat System.Process.Read.Convenience System.Process.Read.Monad - System.Process.Read.Verbosity Build-depends: base >= 4 && < 5, process, - process-listlike >= 0.6, + process-listlike >= 0.9, bytestring, deepseq, HUnit, @@ -42,7 +40,3 @@ time, unix, utf8-string - -Executable tests - Main-Is: Tests/Main.hs - GHC-Options: -Wall -O2 -threaded -rtsopts