summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-07-28 14:01:01 +0200
committertv <tv@shackspace.de>2014-07-28 14:01:01 +0200
commitcb460f6382e237c95c4201c31e409118d93e1235 (patch)
treeb69d1b30750a0423ae0d54c4170b3910aa3d45be
parent9c3f9557ded1e2d08d3799fb202f86becf1ea534 (diff)
Process: initial commit
-rw-r--r--Main.hs46
-rw-r--r--Process.hs98
-rw-r--r--hack.cabal3
3 files changed, 137 insertions, 10 deletions
diff --git a/Main.hs b/Main.hs
index adb022d..36d066d 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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)
diff --git a/hack.cabal b/hack.cabal
index 709576c..13e26e6 100644
--- a/hack.cabal
+++ b/hack.cabal
@@ -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