From cb460f6382e237c95c4201c31e409118d93e1235 Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Mon, 28 Jul 2014 14:01:01 +0200
Subject: Process: initial commit

---
 Main.hs    | 46 +++++++++++++++++++++++------
 Process.hs | 98 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 hack.cabal |  3 +-
 3 files changed, 137 insertions(+), 10 deletions(-)
 create mode 100644 Process.hs

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
-- 
cgit v1.2.3