diff options
| -rw-r--r-- | Main.hs | 46 | ||||
| -rw-r--r-- | Process.hs | 98 | ||||
| -rw-r--r-- | hack.cabal | 3 |
3 files changed, 137 insertions, 10 deletions
@@ -21,14 +21,16 @@ import Control.Monad.State import Control.Monad.Writer import Buffer +import Process data VTConfig = VTConfig - { + { withOutput :: IO () -> IO () } data VTState = VTState { buffer :: Buffer , mode :: Mode + , processCount :: Int } main :: IO () @@ -43,7 +45,8 @@ main = do let st = VTState { mode = InsertMode - , buffer = ("Was geht ab, Junge?", " ^_^") + , buffer = ("", "") + , processCount = 0 } lockRef <- newMVar () @@ -58,12 +61,16 @@ main = do renderInputLine (mode q) (buffer q) hFlush stdout + let cf = VTConfig + { withOutput = withOutput + } + -- render initial input line withOutput $ return () forkIO $ dateThread withOutput 1000000 - uiThread withOutput putState getState + uiThread cf putState getState dateThread :: (IO () -> IO ()) -> Int -> IO () @@ -74,11 +81,11 @@ dateThread withOutput delay = forever $ do threadDelay delay -uiThread :: (IO () -> IO ()) -> (VTState -> IO ()) -> IO VTState -> IO () -uiThread withOutput putState getState = forever $ do +uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO () +uiThread cf putState getState = forever $ do q0 <- getState - ((eitCmd, lines), q1) <- runVT VTConfig q0 $ do + ((eitCmd, lines), q1) <- runVT cf q0 $ do c <- getCommand (mode q0) execCommand c return c @@ -96,7 +103,7 @@ uiThread withOutput putState getState = forever $ do _ -> Nothing - withOutput $ do + withOutput cf $ do forM_ lines putStrLn case mbErr of @@ -213,8 +220,29 @@ execCommand (InsertString s) = modifyBuffer (insertString s) execCommand ExecuteInputBuffer = do - b <- gets buffer - tell [ "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ] + + ---- XXX hack to replace empty command line + --gets (null . showBuffer . buffer) >>= flip when + -- (modify $ \q -> q { buffer = ("!","") }) + + st <- get + + case showBuffer (buffer st) of + '!' : cmdline -> do + --tell [ "spawn: " ++ cmdline ] + -- "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ] + -- TODO register process + i <- state $ \ q -> + let i = processCount q + 1 + in (i, q { processCount = i }) + cf <- ask + liftIO $ forkIO $ spawn i (withOutput cf) cmdline + return () + "" -> do + liftIO ringBell + s -> do + tell [ "input: <" ++ (concat $ map (reform 32) s) ++ ">" ] + modifyBuffer (const emptyBuffer) execCommand KillNextChar = do diff --git a/Process.hs b/Process.hs new file mode 100644 index 0000000..5c53681 --- /dev/null +++ b/Process.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecordWildCards #-} +module Process + ( spawn + , module System.Process + ) where + +import Control.Monad (unless, when) +import System.IO +import System.Process +import Control.Concurrent + +type OutputWrapper = IO () -> IO () + +data OutStreamType = Stderr | Stdout + +color :: OutStreamType -> String +color Stderr = "31" +color Stdout = "32" + +data ReaperConfig = ReaperConfig + { withOutput :: OutputWrapper + , jobName :: String + , openFdsRef :: MVar Int + , processHandle :: ProcessHandle + , streamHandle :: Handle + , streamType :: OutStreamType + } + + +spawn :: Int -> OutputWrapper -> String -> IO () +spawn jobId _withOutput cmdline = do + + -- TODO stdin + (Nothing, Just hOut, Just hErr, ph) <- + createProcess (shell cmdline) + { std_in = Inherit -- TODO close + , std_out = CreatePipe + , std_err = CreatePipe + } + + _openFdsRef <- newMVar 2 + + let rcOut = ReaperConfig + { streamType = Stdout + , streamHandle = hOut + , withOutput = _withOutput + , jobName = '&' : show jobId + , openFdsRef = _openFdsRef + , processHandle = ph + } + rcErr = rcOut + { streamType = Stderr + , streamHandle = hErr + } + + forkIO $ reap rcOut + reap rcErr + + +reap :: ReaperConfig -> IO () +reap rc@ReaperConfig{..} = do + forLines_ streamHandle $ \line -> + withOutput $ do + putStrLn $ + "\x1b[35m" ++ jobName ++ "\x1b[m " ++ + "\x1b[" ++ (color streamType) ++ "m" ++ line ++ "\x1b[m" + + i <- decMVar openFdsRef + + --withOutput $ + -- putStrLn $ "\x1b[35m" ++ name ++ "\x1b[m eof" + + when (i == 0) $ finish rc + + hClose streamHandle + myThreadId >>= killThread + + +finish :: ReaperConfig -> IO () +finish ReaperConfig{..} = do + exitCode <- waitForProcess processHandle + withOutput $ + putStrLn $ "\x1b[35m" ++ jobName ++ "\x1b[m exit: " ++ show exitCode + + +decMVar :: MVar Int -> IO Int +decMVar = + flip modifyMVar dec + where + dec i = let i' = i - 1 in return (i', i') + + + +-- TODO move utilities somewhere else +forLines_ :: Handle -> (String -> IO ()) -> IO () +forLines_ h f = rec + where + rec = hIsEOF h >>= flip unless (hGetLine h >>= f >> rec) @@ -14,9 +14,10 @@ Executable hack main-is: Main.hs Build-depends: + mtl, old-locale, + process, time, - mtl, base ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 |