process: Switch to handle-based implementation; add an interactive example

(the interactive example doesn't fully work yet)

reflex-vty.cabal

@@ -40,7 +40,6 @@ library
     dependent-map                     >= 0.2.4 && < 0.4,
     dependent-sum                     >= 0.3 && < 0.7,
     exception-transformers            >= 0.4.0 && < 0.5,
-    io-streams                        >= 1.5 && < 1.6,
     mtl                               >= 2.2.2 && < 2.3,
     primitive                         >= 0.6.3 && < 0.7,
     process                           >= 1.6.4 && < 1.7,
@@ -81,6 +80,7 @@ executable process
     process,
     reflex,
     reflex-vty,
+    temporary,
     text,
     vty
   default-language: Haskell2010

src-bin/process.hs

@@ -1,27 +1,52 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 import Reflex.Network
 import Reflex.Process
 import Reflex.Vty
 
 import Control.Monad
+import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Graphics.Vty as V
 import qualified System.Process as P
+import System.IO.Temp (withSystemTempDirectory)
 
 main :: IO ()
-main = mainWidget $ do
+main = withSystemTempDirectory "asdf" $ \fp -> mainWidget $ do
   exit <- keyCombo (V.KChar 'c', [V.MCtrl])
   t <- tickLossyFromPostBuildTime 1
   col $ do
-    out <- fmap (switch . current) $ fixed 2 $ networkHold (return never) $ ffor t $ \t -> do
-      (out, _) <- createProcess (P.proc "date" []) never
+    -- Repeatedly call the `date` command
+    out <- fixed 2 $ fmap (switch . current) $ networkHold (return never) $ ffor t $ \t -> do
+      (Process { _process_stdout = out }) <- createProcess (P.proc "date" []) never
       row $ do
         fixed 10 $ text $ pure "Tick:"
         stretch $ display $ pure t
       return out
-    fixed 1 $ do
+    -- Display the stdout output of the date command
+    fixed 2 $ do
       row $ do
         fixed 10 $ text "stdout:"
         stretch $ text <=< hold "" $ T.decodeUtf8 <$> out
+    -- Run an interactive command and get user input
+    stretch $ col $ do
+      fixed 2 $ text "Running interactive command. You'll be prompted to remove an empty file that this program has created."
+      let tmpfile = fp <> "/my-temporary-file"
+      (Process { _process_exit = touchExit }) <- fixed 1 $ do
+        text $ pure $ "$> touch " <> T.pack tmpfile
+        createProcess (P.proc "touch" [tmpfile]) never
+      fixed 1 $ text <=< hold "" $ "File created." <$ touchExit
+      fixed 1 $ text $ pure $ "$>  rm -i " <> T.pack tmpfile
+      fixed 4 $ do
+        rec pout <- createProcess (P.proc "rm" ["-i", fp <> "/my-temporary-file"]) $ fmap T.encodeUtf8 $
+              tag (current (_textInput_value i)) enter
+            (i, enter) <- col $ do
+              fixed 1 $ text <=< hold "" $ T.decodeUtf8 <$> _process_stderr pout
+              fixed 3 $ do
+                i <- boxStatic def $ textInput def
+                enter <- key V.KEnter
+                return (i, enter)
+        display <=< hold Nothing $ Just <$> _process_exit pout
+        return ()
   return $ () <$ exit

src/Reflex/Process.hs

@@ -7,26 +7,37 @@ Description: Run interactive shell commands in reflex
 {-# LANGUAGE LambdaCase #-}
 module Reflex.Process
   ( createProcess
+  , Process(..)
   ) where
 
 import Control.Concurrent (forkIO, killThread)
 import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.ByteString (ByteString)
-import GHC.IO.Handle (Handle, hClose)
-import qualified System.IO.Streams as S
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as Char8
+import qualified GHC.IO.Handle as H
+import GHC.IO.Handle (Handle)
+import System.Exit (ExitCode)
 import qualified System.Process as P
 import System.Process hiding (createProcess)
 
 import Reflex
 
+-- | The output of a process
+data Process t = Process
+  { _process_exit :: Event t ExitCode
+  , _process_stdout :: Event t ByteString
+  , _process_stderr :: Event t ByteString
+  }
+
 createRedirectedProcess
   :: (MonadIO m, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m))
   => (Handle -> IO (ByteString -> IO ()))
   -> (Handle -> (ByteString -> IO ()) -> IO (IO ()))
   -> CreateProcess
   -> Event t ByteString
-  -> m (Event t ByteString, Event t ByteString) 
+  -> m (Process t)
 createRedirectedProcess mkWriteInput mkReadOutput p input = do
   let redirectedProc = p
         { std_in = CreatePipe
@@ -45,11 +56,17 @@ createRedirectedProcess mkWriteInput mkReadOutput p input = do
             return (e, t)
       (out, outThread) <- output hOut
       (err, errThread) <- output hErr
-      void $ liftIO $ forkIO $ waitForProcess ph >> do
+      (ecOut, ecTrigger) <- newTriggerEvent
+      void $ liftIO $ forkIO $ waitForProcess ph >>= \ec -> do
+        ecTrigger ec
         P.cleanupProcess po
         killThread outThread
         killThread errThread 
-      return (out, err)
+      return $ Process
+        { _process_exit = ecOut
+        , _process_stdout = out
+        , _process_stderr = err
+        }
     _ -> error "Reflex.Vty.Process.createProcess: Created pipes were not returned by System.Process.createProcess."
 
 -- | Run a shell process, feeding it input using an 'Event' and exposing its output
@@ -62,24 +79,21 @@ createProcess
   :: (MonadIO m, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m))
   => CreateProcess
   -> Event t ByteString
-  -> m (Event t ByteString, Event t ByteString)
+  -> m (Process t)
 createProcess = createRedirectedProcess input output
   where
-    input h = do
-      s <- toOutputStreamWithLocking h
-      return $ flip S.write s . Just
-    output :: Handle -> (ByteString -> IO ()) -> IO (IO ())
+    input h = return $ Char8.hPutStrLn h
     output h trigger = do
-      s <- toInputStreamWithLocking h
-      let go = S.read s >>= \case
-            Nothing -> return ()
-            Just x -> trigger x >> go
+      let go = do
+            open <- H.hIsOpen h
+            readable <- H.hIsReadable h
+            if open && readable
+              then do
+                out <- BS.hGet h 32768
+                if BS.null out
+                  then return ()
+                  else do
+                    void $ trigger out
+                    go
+              else go
       return go
-    toInputStreamWithLocking :: Handle -> IO (S.InputStream ByteString)
-    toInputStreamWithLocking h = S.handleToInputStream h >>=
-      S.atEndOfInput (hClose h) >>=
-        S.lockingInputStream
-    toOutputStreamWithLocking :: Handle -> IO (S.OutputStream ByteString)
-    toOutputStreamWithLocking hin = S.handleToOutputStream hin >>=
-      S.atEndOfOutput (hClose hin) >>=
-        S.lockingOutputStream