packages feed

process-extras 0.4.1.4 → 0.7

raw patch · 15 files changed

+609/−82 lines, 15 filesdep +HUnitdep +data-defaultdep +mtldep ~ListLikedep ~base

Dependencies added: HUnit, data-default, mtl, process-extras

Dependency ranges changed: ListLike, base

Files

.ghci view
@@ -1,4 +1,5 @@ :set -isrc :set -DMIN_VERSION_deepseq(a,b,c)=1 :set -DMIN_VERSION_bytestring(a,b,c)=1-:load System.Process.ListLike+:load Tests+
.travis.yml view
@@ -13,9 +13,6 @@  matrix:   include:-    - env: CABALVER=1.16 GHCVER=7.4.2-      compiler: ": #GHC 7.4.2"-      addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2], sources: [hvr-ghc]}}     - env: CABALVER=1.16 GHCVER=7.6.3       compiler: ": #GHC 7.6.3"       addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
README.md view
@@ -1,10 +1,14 @@-# About--Extra functionality for the [Process library](http://hackage.haskell.org/package/process).+# What is process-extras - * Read process input and output as ByteStrings or Text, or write your own ProcessOutput instance.- * Lazy process input and output (i.e. read output from processes that run forever.)- * ProcessMaker class for more flexibility in the process creation API.+You might want to use this package if+ * You want to read and write ByteStrings or Text to a process rather+   than just Strings+ * You want to read output from a non-terminating process (e.g. yes(1))+ * You want more flexibility in process creation+ * You want various types of progress output from the process to the+   console before capturing its output - indented and prefixed output,+   reporting of the command that started the process, dots to reflect+   the size of the process output, etc.  # Contributing
+ Tests.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP, FlexibleInstances #-}++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import System.Exit (ExitCode(..), exitWith)+import System.Process.Run+import System.Process.ByteString ()+import System.Process.ByteString.Lazy ()+import System.Process.Text ()+import System.Process.Text.Lazy ()+import Test.HUnit++main :: IO ()+main = runTestTT (TestList [test0]) >>= \cts ->+       exitWith $ if errors cts + failures cts > 0+                  then ExitFailure 1+                  else ExitSuccess++instance Eq (Chunk String) where+    (Stdout a) == (Stdout b) = a == b+    (Stderr a) == (Stderr b) = a == b+    (Result a) == (Result b) = a == b+    _ == _ = False++-- Every fourth run these will say:+-- *System.Process.Run> _test4+-- -> ls+-- <interactive>: fd:12: hGetBuffering: illegal operation (handle is closed)+-- <interactive>: fd:14: hGetBuffering: illegal operation (handle is closed)+-- *** Exception: thread blocked indefinitely in an MVar operation++-- Oldest file in /usr/share/doc+file :: FilePath+file = "/usr/share/doc/cron/THANKS"+dir :: FilePath+dir = "/usr/share/doc/cron"++cmd :: CreateProcess+cmd = shell "echo a; echo b 1>&2; echo -n c"++omitProcessHandle :: [Chunk a] -> [Chunk a]+omitProcessHandle [] = []+omitProcessHandle (ProcessHandle _ : more) = omitProcessHandle more+omitProcessHandle (x : xs) = x : omitProcessHandle xs++test0 :: Test+test0 = TestCase $ do+          let expected = (ExitSuccess, "a\nc", "b\n") :: (ExitCode, String, String)+          actual <- collectOutput <$> runT (output >> run cmd "")+          assertEqual "test1" expected actual++-- | What we want to test with these is what gets written to the console,+-- and I haven't yet invested the thought required to do that.  Divert the+-- console output somehow I guess...+_test1 :: IO [Chunk String]+_test1 = runT (output >> run (proc "ls" []) "")+_test2 :: IO [Chunk String]+_test2 = runT (vlevel 0 >> run (proc "ls" []) "")+_test2a :: IO (ExitCode, String, String)+_test2a = runT (silent >> run (proc "ls" []) "")+_test3 :: IO [Chunk String]+_test3 = runT (dots 10 >> run (proc "ls" []) "")+_test4 :: IO [Chunk String]+_test4 = runT (lazy >> indent (const "1> ") (const "2> ") >> run (proc "ls" []) "")+_test5 :: IO [Chunk String]+_test5 = runT (echoStart >> echoEnd >> run (proc "ls" []) "")+_test6 :: IO [Chunk String]+_test6 = (runT (silent >> echoStart >> echoEnd >> run (proc "yes" []) "") :: IO [Chunk String]) >>= return . take 2
changelog view
@@ -1,3 +1,10 @@+haskell-process-extras (0.5) unstable; urgency=low++  * Have writeOutput return the input list rather than ()+  * Additional re-exports from the process package++ -- David Fox <dsf@foxthompson.net>  Mon, 21 Nov 2016 12:45:57 -0800+ haskell-process-extras (0.4.1.4) unstable; urgency=low    * Add changelog and .ghci to Extra-Source-Files list.
process-extras.cabal view
@@ -1,5 +1,5 @@ Name:               process-extras-Version:            0.4.1.4+Version:            0.7 Synopsis:           Process extras Description:        Extends <http://hackage.haskell.org/package/process>.                     Read process input and output as ByteStrings or@@ -13,7 +13,7 @@ Maintainer:         David Fox <dsf@seereason.com> Category:           System Build-type:         Simple-Cabal-version:      >=1.6+Cabal-version:      >=1.10 Extra-source-files:   README.md, .travis.yml, .ghci, changelog Tested-With:        GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC >= 8@@ -23,6 +23,7 @@   Location:         https://github.com/seereason/process-extras  Library+  Default-Language: Haskell2010   ghc-options:      -Wall    Hs-source-dirs:   src@@ -30,19 +31,31 @@   Exposed-modules:     System.Process.ByteString     System.Process.ByteString.Lazy+    System.Process.Chars     System.Process.Common     System.Process.ListLike+    System.Process.Run     System.Process.Text     System.Process.Text.Lazy+    System.Process.Text.Builder    Other-modules:     Utils    Build-depends:     base >= 4.5 && < 5,-    ListLike >= 4,+    data-default,+    ListLike >= 4.4,+    mtl,     process,     bytestring,     text,     deepseq >= 1.1,     generic-deriving >= 1.10++Test-Suite process-extras-tests+  Default-Language: Haskell2010+  type: exitcode-stdio-1.0+  Hs-Source-Dirs: .+  Main-Is: Tests.hs+  Build-Depends: base, HUnit, process-extras
src/System/Process/ByteString.hs view
@@ -20,6 +20,8 @@ instance NFData ByteString #endif +instance ProcessText ByteString Word8+ -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' instance ListLikeProcessIO ByteString Word8 where     forceOutput = return
src/System/Process/ByteString/Lazy.hs view
@@ -21,6 +21,8 @@ instance NFData ByteString #endif +instance ProcessText ByteString Word8+ -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' instance ListLikeProcessIO ByteString Word8 where     forceOutput = C.evaluate . force
+ src/System/Process/Chars.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Process.Chars where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.DeepSeq (force)+import qualified Control.Exception as C (evaluate)+import Data.ListLike.IO (hGetContents)+import Data.Text.Lazy (fromStrict, toChunks)+import Data.ListLike.Chars (Chars(..))+import Prelude hiding (null)+import System.Process+import System.Process.Common+import System.Exit (ExitCode)++-- | Like 'System.Process.readProcessWithExitCode', but specialized for 'Text'+instance ListLikeProcessIO Chars Char where+    forceOutput = C.evaluate . force+    readChunks h = (map (T . fromStrict) . toChunks) <$> hGetContents h++-- | Specialized version for backwards compatibility.+readProcessWithExitCode+    :: FilePath                        -- ^ command to run+    -> [String]                        -- ^ any arguments+    -> Chars                         -- ^ standard input+    -> IO (ExitCode, Chars, Chars) -- ^ exitcode, stdout, stderr+readProcessWithExitCode = System.Process.Common.readProcessWithExitCode++readCreateProcessWithExitCode+    :: CreateProcess                   -- ^ command and arguments to run+    -> Chars                         -- ^ standard input+    -> IO (ExitCode, Chars, Chars) -- ^ exitcode, stdout, stderr+readCreateProcessWithExitCode = System.Process.Common.readCreateProcessWithExitCode
src/System/Process/Common.hs view
@@ -7,29 +7,32 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.Common-    ( ProcessMaker(process)+    ( ProcessMaker(process, showProcessMakerForUser)     , ListLikeProcessIO(forceOutput, readChunks)-    , ProcessOutput(pidf, outf, errf, intf, codef)+    , ProcessText+    , ProcessResult(pidf, outf, errf, intf, codef)     , readProcessWithExitCode     , readCreateProcessWithExitCode-    , readCreateProcess+    , readCreateProcessStrict     , readCreateProcessLazy+    , showCmdSpecForUser+    , showCreateProcessForUser     ) where  import Control.Concurrent-import Control.DeepSeq (NFData)-import Control.Exception as E (SomeException, onException, catch, mask, throw, try)+import Control.Exception as E (SomeException, onException, catch, mask, throw) import Control.Monad-import Data.ListLike as ListLike (null)+import Data.ListLike as ListLike (ListLike, null) import Data.ListLike.IO (ListLikeIO, hGetContents, hPutStr) import Data.Monoid ((<>))+import Data.String (IsString) import Generics.Deriving.Instances () import GHC.IO.Exception (IOErrorType(ResourceVanished), IOException(ioe_type)) import Prelude hiding (null) import System.Exit (ExitCode(..)) import System.IO (Handle, hClose, hFlush, BufferMode, hSetBuffering) import System.IO.Unsafe (unsafeInterleaveIO)-import System.Process (CreateProcess(std_err, std_in, std_out), StdStream(CreatePipe), ProcessHandle, createProcess, proc, waitForProcess, terminateProcess)+import System.Process (CmdSpec(..), CreateProcess(cmdspec, cwd, std_err, std_in, std_out), StdStream(CreatePipe), ProcessHandle, createProcess, proc, showCommandForUser, waitForProcess, terminateProcess) import Utils (forkWait)  #if __GLASGOW_HASKELL__ <= 709@@ -38,20 +41,23 @@ #endif  #if !MIN_VERSION_deepseq(1,4,2)+import Control.DeepSeq (NFData) -- | This instance lets us use DeepSeq's force function on a stream of Chunks. instance NFData ExitCode #endif  class ProcessMaker a where     process :: a -> IO (Handle, Handle, Handle, ProcessHandle)+    showProcessMakerForUser :: a -> String --- | This is the usual maker argument to 'readCreateProcess'.+-- | This is the usual maker argument to 'readCreateProcessLazy'. instance ProcessMaker CreateProcess where     process p = do       (Just inh, Just outh, Just errh, pid) <- createProcess p { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }       return (inh, outh, errh, pid)+    showProcessMakerForUser = showCreateProcessForUser --- | Passing this to 'readCreateProcess' as the maker argument allows+-- | Passing this to 'readCreateProcessLazy' as the maker argument allows -- you to set the buffer mode of the process stdout and stderr handles -- just after the handles are created.  These are set to -- BlockBuffering by default, but for running console commands@@ -62,15 +68,19 @@       hSetBuffering outh outmode       hSetBuffering errh errmode       return (inh, outh, errh, pid)+    showProcessMakerForUser (p, outmode, errmode) =+        showCreateProcessForUser p ++ " outmode=" ++ show outmode ++ ", errmode=" ++ show errmode -class Monoid b => ProcessOutput a b | b -> a where-    pidf :: ProcessHandle -> b-    outf :: a -> b-    errf :: a -> b-    intf :: SomeException -> b-    codef :: ExitCode -> b+class (IsString text, Monoid text, ListLike text char) => ProcessText text char -instance ListLikeProcessIO a c => ProcessOutput a (ExitCode, a, a) where+class Monoid result => ProcessResult text result | result -> text where+    pidf :: ProcessHandle -> result+    outf :: text -> result+    errf :: text -> result+    intf :: SomeException -> result+    codef :: ExitCode -> result++instance ListLikeProcessIO text char => ProcessResult text (ExitCode, text, text) where     pidf _ = mempty     codef c = (c, mempty, mempty)     outf x = (mempty, x, mempty)@@ -84,29 +94,37 @@     mappend x (ExitFailure 0) = x     mappend _ x = x -class ListLikeIO a c => ListLikeProcessIO a c where-    forceOutput :: a -> IO a-    readChunks :: Handle -> IO [a]+-- | Process IO is based on the 'ListLikeIO' class from the ListLike+-- package+class ListLikeIO text char => ListLikeProcessIO text char where+    forceOutput :: text -> IO text+    readChunks :: Handle -> IO [text]     -- ^ Read from a handle, returning a lazy list of the monoid a. --- | Like 'System.Process.readProcessWithExitCode', but with generalized input and output type.+-- | Like 'System.Process.readProcessWithExitCode', but with+-- generalized input and output type.  Aside from the usual text-like+-- types, the output can be a list of Chunk a.  This lets you process+-- the chunks received from stdout and stderr lazil, in the order they+-- are received, as well as the exit code.  Utilities to handle Chunks+-- are provided in System.Process.ListLike. readProcessWithExitCode-    :: ListLikeProcessIO a c =>+    :: ListLikeProcessIO text char =>        FilePath                 -- ^ command to run     -> [String]                 -- ^ any arguments-    -> a               -- ^ standard input-    -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr+    -> text               -- ^ standard input+    -> IO (ExitCode, text, text) -- ^ exitcode, stdout, stderr readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input  readCreateProcessWithExitCode-    :: (ProcessMaker maker, ListLikeProcessIO a c) =>-       maker               -- ^ command and arguments to run-    -> a                   -- ^ standard input-    -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr-readCreateProcessWithExitCode = readCreateProcess+    :: (ProcessMaker maker, ListLikeProcessIO text char) =>+       maker                     -- ^ command and arguments to run+    -> text                      -- ^ standard input+    -> IO (ExitCode, text, text) -- ^ exitcode, stdout, stderr+readCreateProcessWithExitCode = readCreateProcessStrict -readCreateProcess :: (ProcessMaker maker, ProcessOutput a b, ListLikeProcessIO a c) => maker -> a -> IO b-readCreateProcess maker input = mask $ \restore -> do+readCreateProcessStrict :: (ProcessMaker maker, ProcessResult text result, ListLikeProcessIO text char) =>+                           maker -> text -> IO result+readCreateProcessStrict maker input = mask $ \restore -> do     (inh, outh, errh, pid) <- process maker     flip onException       (do terminateProcess pid; hClose inh; hClose outh; hClose errh;@@ -133,8 +151,8 @@        return $ out <> err <> ex --- | Like readCreateProcess, but the output is read lazily.-readCreateProcessLazy :: (ProcessMaker maker, ProcessOutput a b, ListLikeProcessIO a c) => maker -> a -> IO b+-- | Like readCreateProcessStrict, but the output is read lazily.+readCreateProcessLazy :: (ProcessMaker maker, ProcessResult a b, ListLikeProcessIO a c) => maker -> a -> IO b readCreateProcessLazy maker input = mask $ \restore -> do     (inh, outh, errh, pid) <- process maker     onException@@ -150,11 +168,11 @@           waitForProcess pid)  -- | Helper function for readCreateProcessLazy.-readInterleaved :: (ListLikeProcessIO a c, ProcessOutput a b) =>+readInterleaved :: (ListLikeProcessIO a c, ProcessResult a b) =>                    [(a -> b, Handle)] -> IO b -> IO b readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish -readInterleaved' :: forall a b c. (ListLikeProcessIO a c, ProcessOutput a b) =>+readInterleaved' :: forall a b c. (ListLikeProcessIO a c, ProcessResult a b) =>                     [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b readInterleaved' pairs finish res = do   mapM_ (forkIO . uncurry readHandle) pairs@@ -200,3 +218,12 @@ ignoreResourceVanished :: IO () -> IO () ignoreResourceVanished action =     action `E.catch` (\e -> if ioe_type e == ResourceVanished then return () else ioError e)++-- | System.Process utility functions.+showCreateProcessForUser :: CreateProcess -> String+showCreateProcessForUser p =+    showCmdSpecForUser (cmdspec p) ++ maybe "" (\ d -> " (in " ++ d ++ ")") (cwd p)++showCmdSpecForUser :: CmdSpec -> String+showCmdSpecForUser (ShellCommand s) = s+showCmdSpecForUser (RawCommand p args) = showCommandForUser p args
src/System/Process/ListLike.hs view
@@ -8,27 +8,44 @@ {-# LANGUAGE CPP, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module System.Process.ListLike-    ( ProcessMaker(process)-    , ListLikeProcessIO(forceOutput)-    , ProcessOutput(pidf, outf, errf, codef, intf)+    (+    -- * Classes for process IO monad, output type, and creation type+      ListLikeProcessIO(forceOutput)+    , ProcessText+    , ProcessResult(pidf, outf, errf, codef, intf)+    , ProcessMaker(process, showProcessMakerForUser)++    -- * The generalized process runners     , readCreateProcess+    , readCreateProcessStrict     , readCreateProcessLazy     , readCreateProcessWithExitCode     , readProcessWithExitCode++    -- * Utility functions based on showCommandForUser+    , showCreateProcessForUser+    , showCmdSpecForUser++    -- * The Chunk type     , Chunk(..)     , collectOutput     , foldOutput     , writeOutput-    , showCreateProcessForUser-    , showCmdSpecForUser+    , writeChunk++    -- * Re-exports from process+    , CmdSpec(..)+    , CreateProcess(..)     , proc     , shell+    , showCommandForUser     ) where  import Control.DeepSeq (force) import Control.Exception as C (evaluate, SomeException, throw) import Data.ListLike.IO (hGetContents, hPutStr, ListLikeIO) #if __GLASGOW_HASKELL__ <= 709+import Control.Applicative ((<$>), (<*>)) import Data.Monoid (mempty, mconcat) #endif import Data.Text (unpack)@@ -38,19 +55,18 @@ import System.Process (CmdSpec(..), CreateProcess(..), proc, ProcessHandle, shell, showCommandForUser) import System.Process.ByteString () import System.Process.ByteString.Lazy ()-import System.Process.Common (ProcessMaker(process), ListLikeProcessIO(forceOutput, readChunks), ProcessOutput(pidf, outf, errf, codef, intf),-                              readCreateProcess, readCreateProcessLazy, readCreateProcessWithExitCode, readProcessWithExitCode)+import System.Process.Common+    (ProcessMaker(process, showProcessMakerForUser), ListLikeProcessIO(forceOutput, readChunks),+     ProcessText, ProcessResult(pidf, outf, errf, codef, intf), readCreateProcessStrict, readCreateProcessLazy,+     readCreateProcessWithExitCode, readProcessWithExitCode, showCmdSpecForUser, showCreateProcessForUser) import System.Process.Text ()+import System.Process.Text.Builder () import System.Process.Text.Lazy () --- | System.Process utility functions.-showCreateProcessForUser :: CreateProcess -> String-showCreateProcessForUser p =-    showCmdSpecForUser (cmdspec p) ++ maybe "" (\ d -> " (in " ++ d ++ ")") (cwd p)+instance ProcessText String Char -showCmdSpecForUser :: CmdSpec -> String-showCmdSpecForUser (ShellCommand s) = s-showCmdSpecForUser (RawCommand p args) = showCommandForUser p args+readCreateProcess :: (ProcessMaker maker, ProcessResult text result, ListLikeProcessIO text char) => maker -> text -> IO result+readCreateProcess = readCreateProcessLazy  -- | Like 'System.Process.readProcessWithExitCode' that takes a 'CreateProcess'. instance ListLikeProcessIO String Char where@@ -80,25 +96,25 @@ instance Show ProcessHandle where     show _ = "<process>" -instance ListLikeProcessIO a c => ProcessOutput a [Chunk a] where+instance ListLikeProcessIO a c => ProcessResult a [Chunk a] where     pidf p = [ProcessHandle p]     outf x = [Stdout x]     errf x = [Stderr x]     intf e = throw e     codef c = [Result c] -instance ListLikeProcessIO a c => ProcessOutput a (ExitCode, [Chunk a]) where+instance ListLikeProcessIO a c => ProcessResult a (ExitCode, [Chunk a]) where     pidf p = (mempty, [ProcessHandle p])     codef c = (c, mempty)     outf x = (mempty, [Stdout x])     errf x = (mempty, [Stderr x])     intf e = throw e -foldOutput :: (ProcessHandle -> r)-           -> (a -> r)-           -> (a -> r)-           -> (SomeException -> r)-           -> (ExitCode -> r)+foldOutput :: (ProcessHandle -> r) -- ^ called when the process handle becomes known+           -> (a -> r) -- ^ stdout handler+           -> (a -> r) -- ^ stderr handler+           -> (SomeException -> r) -- ^ exception handler+           -> (ExitCode -> r) -- ^ exit code handler            -> Chunk a            -> r foldOutput p _ _ _ _ (ProcessHandle x) = p x@@ -107,16 +123,23 @@ foldOutput _ _ _ i _ (Exception x) = i x foldOutput _ _ _ _ r (Result x) = r x --- | Turn a @[Chunk a]@ into any other instance of 'ProcessOutput'.-collectOutput :: ProcessOutput a b => [Chunk a] -> b+-- | Turn a @[Chunk a]@ into any other instance of 'ProcessOutput'.  I+-- usually use this after processing the chunk list to turn it into+-- the (ExitCode, String, String) type returned by readProcessWithExitCode.+collectOutput :: ProcessResult a b => [Chunk a] -> b collectOutput xs = mconcat $ map (foldOutput pidf outf errf intf codef) xs  -- | Send Stdout chunks to stdout and Stderr chunks to stderr.-writeOutput :: ListLikeIO a c => [Chunk a] -> IO ()-writeOutput [] = return ()-writeOutput (x : xs) =-    foldOutput (\_ -> return ())-               (hPutStr stdout)-               (hPutStr stderr)-               (\_ -> return ())-               (\_ -> return ()) x >> writeOutput xs+-- Returns input list unmodified.+writeOutput :: ListLikeIO a c => [Chunk a] -> IO [Chunk a]+writeOutput [] = return []+writeOutput (x : xs) = (:) <$> writeChunk x <*> writeOutput xs+++writeChunk :: ListLikeIO a c => Chunk a -> IO (Chunk a)+writeChunk x =+    foldOutput (\_ -> return x)+               (\s -> hPutStr stdout s >> return x)+               (\s -> hPutStr stderr s >> return x)+               (\_ -> return x)+               (\_ -> return x) x
+ src/System/Process/Run.hs view
@@ -0,0 +1,304 @@+-- | Flexible control of progress reporting for readCreateProcess and friends.++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}++module System.Process.Run+    ( +    -- * Monad transformer+      RunT+    , runT+    , RunState(..)+    , OutputStyle(..)+    -- * Monad class+    , RunM+    -- * Modify moand RunM state parameters+    , echoStart+    , echoEnd+    , output+    , silent+    , dots+    , indent+    , vlevel+    , quieter+    , noisier+    , lazy+    , strict+    , message+    -- * Monadic process runner+    , run+    -- * Re-exports+    , module System.Process.ListLike+    ) where++#if __GLASGOW_HASKELL__ <= 709+import Data.Monoid (Monoid, mempty)+#endif+import Control.Monad (when)+import Control.Monad.State (evalState, evalStateT, get, modify, MonadState, put, StateT)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import Data.Char (ord)+import Data.Default (Default(def))+import Data.ListLike as ListLike+    (break, fromList, head, hPutStr, length, ListLike, null, putStr, singleton, tail)+import Data.Monoid ((<>))+import Data.String (IsString, fromString)+import Data.Text (Text)+import Data.Word (Word8)+import qualified Data.Text.Lazy as Lazy (Text)+import System.IO (hPutStr, hPutStrLn, stderr)+import System.Process.ListLike++-- | This is the state record that controls the output style.+data RunState text+    = RunState+      { _output :: OutputStyle -- ^ Overall style of output+      , _outprefix :: text     -- ^ Prefix for lines of stdout+      , _errprefix :: text     -- ^ Prefix for lines of stderr+      , _echoStart :: Bool     -- ^ Echo command as process starts+      , _echoEnd :: Bool       -- ^ Echo command as process finishes+      , _verbosity :: Int      -- ^ A progression of progress modes+      , _lazy :: Bool          -- ^ Use the lazy or strict runner?+      , _message :: text       -- ^ Extra text for start/end message - e.g. the change root+      }++type RunT text m = StateT (RunState text) m++class (MonadState (RunState text) m,+       ProcessText text char,+       ListLikeProcessIO text char,+       MonadIO m, IsString text, Eq char, Dot char) =>+    RunM text char m++instance Dot Word8 where+    dot = fromIntegral (ord '.')++instance (MonadIO m, MonadState (RunState String) m) => RunM String Char m+instance (MonadIO m, MonadState (RunState Text) m) => RunM Text Char m+instance (MonadIO m, MonadState (RunState Lazy.Text) m) => RunM Lazy.Text Char m+instance (MonadIO m, MonadState (RunState ByteString) m) => RunM ByteString Word8 m+instance (MonadIO m, MonadState (RunState Lazy.ByteString) m) => RunM Lazy.ByteString Word8 m++runT :: forall m text char a. (MonadIO m, ProcessText text char) => RunT text m a -> m a+runT action = evalStateT action (def :: RunState text)++data OutputStyle+    = Dots Int  -- ^ Output one dot per n output characters+    | All       -- ^ send process stdout to console stdout and process stderr to console stderr+    | Indented  -- ^ Output with prefixes+    | Silent    -- ^ No output++instance ProcessText text char => Default (RunState text) where+    def = RunState { _outprefix = fromString "1> "+                   , _errprefix = fromString "2> "+                   , _output = All+                   , _echoStart = True+                   , _echoEnd = True+                   , _verbosity = 3+                   , _lazy = False+                   , _message = mempty }++{-+class (Monoid text, MonadIO m) => MonadRun m text where+    type Text m+    getRunState :: m (RunState text)+    putRunState :: RunState text -> m ()++instance Monoid text => MonadRun IO text where+    getRunState = return def+    putRunState _ = return ()++instance (MonadIO m, Monoid t, MonadState (RunState t) m) => MonadRun m t where+    getRunState = get+    putRunState = put+-}++noEcho :: (MonadState (RunState t) m) => m ()+noEcho = modify (\x -> x { _echoStart = False, _echoEnd = False })++echoStart :: (MonadState (RunState t) m) => m ()+echoStart = modify (\x -> x { _echoStart = True })++echoEnd :: (MonadState (RunState t) m) => m ()+echoEnd = modify (\x -> x { _echoEnd = True })++output :: (MonadState (RunState t) m) => m ()+output = modify (\x -> x { _output = All })++silent :: (MonadState (RunState t) m) => m ()+silent = modify (\x -> x { _output = Silent })++dots :: (MonadState (RunState t) m) => Int -> m ()+dots n = modify (\x -> x { _output = Dots n })++-- | Modify the indentation prefixes for stdout and stderr in the+-- progress monad.+indent :: (MonadState (RunState t) m, ListLike t char) => (t -> t) -> (t -> t) -> m ()+indent so se = modify $ \x ->+    let so' = so (_outprefix x)+        se' = se (_errprefix x) in+    x { _outprefix = so'+      , _errprefix = se'+      , _output = if ListLike.null so' &&+                     ListLike.null se' then _output x else Indented }++noIndent :: (MonadState (RunState text) m, ListLike text char) => m ()+noIndent = indent (const mempty) (const mempty)++-- | Set verbosity to a specific level from 0 to 3.+-- vlevel :: (MonadIO m, Monoid text, MonadState (RunState text) m) => Int -> m ()+-- vlevel :: forall m text char. (IsString text, ListLike text char, MonadIO m) => Int -> m ()+vlevel :: forall m text char.+          (IsString text, ListLike text char, MonadIO m, MonadState (RunState text) m) =>+          Int -> m ()+vlevel n = do+  modify (\x -> x {_verbosity = n})+  case n of+    _ | n <= 0 -> noEcho >> silent >> noIndent -- No output+    1 -> vlevel 0 >> echoStart                 -- Output command at start+    2 -> vlevel 1 >> echoEnd >> dots 100       -- Output command at start and end, dots to show output+    _ ->                                       -- echo command at start and end, and send all output+                                               -- to the console with channel prefixes 1> and 2>+          vlevel 2 >> output >> indent (const (fromString "1> ")) (const (fromString ("2> ")))++quieter :: RunM text char m => m ()+quieter = get >>= \x -> vlevel (_verbosity x - 1)++noisier :: RunM text char m => m ()+noisier = get >>= \x -> vlevel (_verbosity x + 1)++strict :: RunM text char m => m ()+strict = modify (\x -> x { _lazy = False })++lazy :: RunM text char m => m ()+lazy = modify (\x -> x { _lazy = True})++message :: RunM text char m => (text -> text) -> m ()+message f = modify (\x -> x { _message = f (_message x) })++class Dot c where+    dot :: c++instance Dot Char where+    dot = '.'++run' :: forall m maker text char.+        (RunM text char m,+         ProcessMaker maker) =>+        maker -> text -> m [Chunk text]+run' maker input = do+  st0 <- get+  when (_echoStart st0) (liftIO $ hPutStrLn stderr ("-> " ++ showProcessMakerForUser maker))+  result <- liftIO $ (if _lazy st0 then readCreateProcessLazy else readCreateProcess) maker input >>= doOutput st0+  when (_echoEnd st0) (liftIO $ hPutStrLn stderr ("<- " ++ showProcessMakerForUser maker))+  return result+    where+      doOutput :: RunState text -> [Chunk text] -> IO [Chunk text]+      doOutput (RunState {_output = Dots n}) cs = putDotsLn n cs+      doOutput (RunState {_output = Silent}) cs = return cs+      doOutput (RunState {_output = All}) cs = writeOutput cs+      doOutput (RunState {_output = Indented, _outprefix = outp, _errprefix = errp}) cs = writeOutputIndented outp errp cs++run :: forall m maker text char result.+       (RunM text char m,+        ProcessMaker maker,+        ProcessResult text result) =>+       maker -> text -> m result+run maker input = run' maker input >>= return . collectOutput++-- | Output the dotified text of a chunk list with a newline at EOF.+-- Returns the original list.+putDotsLn :: (ListLikeProcessIO text char, Dot char) =>+             Int -> [Chunk text] -> IO [Chunk text]+putDotsLn cpd chunks = putDots cpd chunks >>= \ r -> System.IO.hPutStr stderr "\n" >> return r++-- | Output the dotified text of a chunk list. Returns the original+-- (undotified) list.+putDots :: (ListLikeProcessIO text char, Dot char) => Int -> [Chunk text] -> IO [Chunk text]+putDots charsPerDot chunks =+    evalStateT (mapM (\ x -> dotifyChunk charsPerDot x >>= mapM_ (lift . putChunk) >> return x) chunks) 0++-- | dotifyChunk charsPerDot dot chunk - Replaces every charsPerDot+-- characters in the Stdout and Stderr chunks with one dot.  Runs in+-- the state monad to keep track of how many characters had been seen+-- when the previous chunk finished.  chunks.+dotifyChunk :: forall text char m. (Monad m, ListLike text char, Dot char) =>+               Int -> Chunk text -> StateT Int m [Chunk text]+dotifyChunk charsPerDot chunk =+    case chunk of+      Stdout x -> doChars (ListLike.length x)+      Stderr x -> doChars (ListLike.length x)+      _ -> return [chunk]+    where+      doChars :: Int -> StateT Int m [Chunk text]+      doChars count = do+        remaining <- get+        let (count', remaining') = divMod (remaining + count) (fromIntegral charsPerDot)+        put remaining'+        if (count' > 0) then return [Stderr (ListLike.fromList (replicate count' dot))] else return []++-- | Write the Stdout chunks to stdout and the Stderr chunks to stderr.+putChunk :: ListLikeProcessIO text char => Chunk text -> IO ()+putChunk (Stdout x) = ListLike.putStr x+putChunk (Stderr x) = ListLike.hPutStr stderr x+putChunk _ = return ()++writeOutputIndented :: (ListLikeProcessIO text char, Eq char, IsString text) =>+                       text -> text -> [Chunk text] -> IO [Chunk text]+writeOutputIndented outp errp chunks =+    mapM (\(c, cs) -> mapM_ writeChunk cs >> return c) (indentChunks outp errp chunks)++-- | Pure function to indent the text of a chunk list.+indentChunks :: forall text char. (ListLikeProcessIO text char, Eq char, IsString text) =>+                text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]+indentChunks outp errp chunks =+    evalState (mapM (indentChunk nl outp errp) chunks) BOL+    where+      nl :: char+      nl = ListLike.head (fromString "\n" :: text)++-- | The monad state, are we at the beginning of a line or the middle?+data BOL = BOL | MOL deriving (Eq)++-- | Indent the text of a chunk with the prefixes given for stdout and+-- stderr.  The state monad keeps track of whether we are at the+-- beginning of a line - when we are and more text comes we insert one+-- of the prefixes.+indentChunk :: forall m text char.+               (Eq char, ListLike text char, MonadState BOL m) =>+               char -> text -> text -> Chunk text -> m (Chunk text, [Chunk text])+indentChunk nl outp errp chunk =+    case chunk of+      Stdout x -> doText Stdout outp x >>= return . (chunk,)+      Stderr x -> doText Stderr errp x >>= return . (chunk,)+      _ -> return (chunk, [chunk])+    where+      -- doText :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+      doText con pre x = do+        let (hd, tl) = ListLike.break (== nl) x+        hd' <- doHead con pre hd+        tl' <- doTail con pre tl+        return $ hd' <> tl'+      -- doHead :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+      doHead _ _ x | ListLike.null x = return []+      doHead con pre x = do+        bol <- get+        case bol of+          BOL -> put MOL >> return [con (pre <> x)]+          MOL -> return [con x]+      -- doTail :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+      doTail _ _ x | ListLike.null x = return []+      doTail con pre x = do+        bol <- get+        put BOL+        tl <- doText con pre (ListLike.tail x)+        return $ (if bol == BOL then [con pre] else []) <> [con (singleton nl)] <> tl
src/System/Process/Text.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP, MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.Text where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import Control.Monad import Data.ListLike.IO (hGetContents) import Data.Text (Text)@@ -10,6 +12,8 @@ import System.Process import System.Process.Common import System.Exit (ExitCode)++instance ProcessText Text Char  -- | Like 'System.Process.readProcessWithExitCode', but using 'Text' instance ListLikeProcessIO Text Char where
+ src/System/Process/Text/Builder.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Process.Text.Builder where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.DeepSeq (force)+import qualified Control.Exception as C (evaluate)+import Data.ListLike.IO (hGetContents)+import Data.Text.Lazy (toChunks)+import Data.Text.Lazy.Builder (Builder, fromText)+import Prelude hiding (null)+import System.Process+import System.Process.Common+import System.Exit (ExitCode)++-- | Like 'System.Process.readProcessWithExitCode', but using 'Text'+instance ListLikeProcessIO Builder Char where+    forceOutput = C.evaluate . force+    readChunks h = (map fromText . toChunks) <$> hGetContents h++-- | Specialized version for backwards compatibility.+readProcessWithExitCode+    :: FilePath                        -- ^ command to run+    -> [String]                        -- ^ any arguments+    -> Builder                         -- ^ standard input+    -> IO (ExitCode, Builder, Builder) -- ^ exitcode, stdout, stderr+readProcessWithExitCode = System.Process.Common.readProcessWithExitCode++readCreateProcessWithExitCode+    :: CreateProcess                   -- ^ command and arguments to run+    -> Builder                         -- ^ standard input+    -> IO (ExitCode, Builder, Builder) -- ^ exitcode, stdout, stderr+readCreateProcessWithExitCode = System.Process.Common.readCreateProcessWithExitCode
src/System/Process/Text/Lazy.hs view
@@ -1,21 +1,25 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP, MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.Text.Lazy where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import Control.DeepSeq (force) import qualified Control.Exception as C (evaluate) import Data.ListLike.IO (hGetContents)-import Data.Text.Lazy (Text, fromChunks, toChunks)+import Data.Text.Lazy (Text, fromStrict, toChunks) import Prelude hiding (null) import System.Process import System.Process.Common import System.Exit (ExitCode) +instance ProcessText Text Char+ -- | Like 'System.Process.readProcessWithExitCode', but using 'Text' instance ListLikeProcessIO Text Char where     forceOutput = C.evaluate . force-    readChunks h = (map (fromChunks . (: [])) . toChunks) <$> hGetContents h+    readChunks h = (map fromStrict . toChunks) <$> hGetContents h  -- | Specialized version for backwards compatibility. readProcessWithExitCode