git.iko.soy/odn
on master help sign in
odn/src/Main.hs
67 lines 1.8 kB history raw
1module Main (main) where
3import Colourista
4import Control.Concurrent
5import Control.Monad
6import Data.Functor
7import qualified Data.Text as T
8import System.Environment
9import System.Exit
10import System.IO
11import System.Process.Typed
13main :: IO ()
14main = getArgs >>= runPrograms
16runPrograms :: [String] -> IO ()
17runPrograms progs = do
18 exited <- newEmptyMVar
19 processes <- forM (zip progs (prettifyProcesses progs)) $ \(prog, pretty) -> do
20 p <-
21 startProcess . setStderr createPipe
22 . setStdout createPipe
23 . setStdin nullStream
24 $ shell prog
25 void . forkIO $ do
26 e <- waitExitCode p
27 putMVar exited (pretty, e)
28 return (pretty, p)
30 forever $ do
31 isEmpty <- isEmptyMVar exited
32 let writeLogs =
33 forM (zip colors processes) $ \(color, (prog, p)) -> do
34 (||)
35 <$> writeOutput [color] prog (getStdout p)
36 <*> writeOutput [color] prog (getStderr p)
38 if isEmpty
39 then do
40 written <- writeLogs
41 if or written
42 then return ()
43 else threadDelay 100000
44 else do
45 (prog, exitCode) <- readMVar exited
46 infoMessage $ T.pack prog <> " exited with " <> (T.pack . show) exitCode
47 forM_ processes (stopProcess . snd)
48 exitWith exitCode
50colors :: [String]
51colors = cycle [green, blue, magenta, cyan]
53writeOutput :: [String] -> String -> Handle -> IO Bool
54writeOutput color prog h = do
55 inputAvailable <- hReady h
56 if inputAvailable
57 then do
58 l <- hGetLine h
59 putStrLn $ formatWith color (prog <> " | ") <> l
60 return True
61 else return False
63prettifyProcesses :: [String] -> [String]
64prettifyProcesses ps' =
65 let ps = take 50 <$> ps'
66 maxLen = maximum . fmap length $ ps
67 in ps <&> \p -> p <> replicate (maxLen - length p) ' '