module System.ProcessControl where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Either
import Data.List
import Data.Monoid
import System.IO
import System.Process as P
type ProcessControl = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
data TrackedProcess = TrackedProcess { name :: String
, color :: String
, execPath :: String
, args :: [String]
} deriving (Show)
stack :: String
stack = "stack"
process :: TrackedProcess -> IO ProcessControl
process TrackedProcess{..} = createProcess
(P.proc execPath args)
{ std_out = CreatePipe, std_err = CreatePipe }
data Tracker = Tracker { trackerName :: String, trackedProcess :: ProcessHandle, trackerThreads :: [ThreadId] }
instance Show Tracker where
show Tracker{..} = "Tracker { trackerName = " ++ trackerName ++ ", trackerThreads = "++ show trackerThreads ++ "}"
data Message = Message { origin :: String, msgColor :: String, msg :: String }
trackProcess :: Chan Message -> TrackedProcess -> IO (Either IOException Tracker)
trackProcess chan t@TrackedProcess{..} = do
procStart <- try (process t)
case procStart of
Right (Nothing, Just aout, Just aerr, aProc) -> do
outtid <- readOutput aout
errtid <- readOutput aerr
putStrLn $ "\x1b[31mstarted " ++ name ++ " (" ++ execPath ++ " " ++ concat (intersperse " " args) ++ ")\x1b[0m"
let tr = Tracker name aProc [outtid, errtid]
return $ Right tr
Right _ -> error "unhandled pattern"
Left e -> print e >> (return $ Left e)
where
readOutput hd = forkIO $ forever $ do
l <- hGetLine hd
writeChan chan (Message name color l)
trackProcesses :: [ TrackedProcess ] -> IO ()
trackProcesses toTrack = do
chan <- newChan
procs <- mapM (trackProcess chan) toTrack
when (null (lefts procs)) $ forever $ do
out <- readChan chan
putStrLn $ msgColor out <> "[" <> origin out <> "] - \x1b[0m" <> msg out