Very simple v1

This commit is contained in:
iko 2020-12-24 17:22:27 +03:00
commit 4ab5a926b1
4 changed files with 99 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
odn.cabal

26
package.yaml Normal file
View 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
View 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
View File

@ -0,0 +1,5 @@
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml
packages:
- .