mirror of
https://github.com/ilyakooo0/odn.git
synced 2024-11-25 23:13:09 +03:00
Very simple v1
This commit is contained in:
commit
4ab5a926b1
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
odn.cabal
|
26
package.yaml
Normal file
26
package.yaml
Normal file
@ -0,0 +1,26 @@
|
||||
name: odn
|
||||
# synopsis:
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
- typed-process
|
||||
- colourista
|
||||
- text
|
||||
|
||||
executable:
|
||||
source-dirs: src
|
||||
main: Main.hs
|
||||
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -Weverything
|
||||
- -Wno-implicit-prelude
|
||||
- -Wno-safe
|
||||
- -Wno-missing-import-lists
|
||||
- -Wno-partial-fields
|
||||
- -Wno-all-missed-specialisations
|
||||
- -Wno-missing-local-signatures
|
||||
- -Wno-unsafe
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
67
src/Main.hs
Normal file
67
src/Main.hs
Normal file
@ -0,0 +1,67 @@
|
||||
module Main (main) where
|
||||
|
||||
import Colourista
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
import Data.Functor
|
||||
import qualified Data.Text as T
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Process.Typed
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= runPrograms
|
||||
|
||||
runPrograms :: [String] -> IO ()
|
||||
runPrograms progs = do
|
||||
exited <- newEmptyMVar
|
||||
processes <- forM (zip progs (prettifyProcesses progs)) $ \(prog, pretty) -> do
|
||||
p <-
|
||||
startProcess . setStderr createPipe
|
||||
. setStdout createPipe
|
||||
. setStdin nullStream
|
||||
$ shell prog
|
||||
void . forkIO $ do
|
||||
e <- waitExitCode p
|
||||
putMVar exited (pretty, e)
|
||||
return (pretty, p)
|
||||
|
||||
forever $ do
|
||||
isEmpty <- isEmptyMVar exited
|
||||
let writeLogs =
|
||||
forM (zip colors processes) $ \(color, (prog, p)) -> do
|
||||
(||)
|
||||
<$> writeOutput [color] prog (getStdout p)
|
||||
<*> writeOutput [color] prog (getStderr p)
|
||||
|
||||
if isEmpty
|
||||
then do
|
||||
written <- writeLogs
|
||||
if or written
|
||||
then return ()
|
||||
else threadDelay 100000
|
||||
else do
|
||||
(prog, exitCode) <- readMVar exited
|
||||
infoMessage $ T.pack prog <> " exited with " <> (T.pack . show) exitCode
|
||||
forM_ processes (stopProcess . snd)
|
||||
exitWith exitCode
|
||||
|
||||
colors :: [String]
|
||||
colors = cycle [green, blue, magenta, cyan]
|
||||
|
||||
writeOutput :: [String] -> String -> Handle -> IO Bool
|
||||
writeOutput color prog h = do
|
||||
eof <- hIsEOF h
|
||||
if eof
|
||||
then return False
|
||||
else do
|
||||
l <- hGetLine h
|
||||
putStrLn $ formatWith color (prog <> " | ") <> l
|
||||
return True
|
||||
|
||||
prettifyProcesses :: [String] -> [String]
|
||||
prettifyProcesses ps' =
|
||||
let ps = take 50 <$> ps'
|
||||
maxLen = maximum . fmap length $ ps
|
||||
in ps <&> \p -> p <> replicate (maxLen - length p) ' '
|
5
stack.yaml
Normal file
5
stack.yaml
Normal file
@ -0,0 +1,5 @@
|
||||
resolver:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml
|
||||
|
||||
packages:
|
||||
- .
|
Loading…
Reference in New Issue
Block a user