Re: [wxhaskell-devel] processExecAsync and processExecAsyncTimed don't work in version 0.10.3

[Bernd H. <ber...@ic...>]

{-# LANGUAGE PatternSignatures #-}

module WxProcess
    ( wxExecProcess
    , ExitCode(..)
    )
where

import Control.Concurrent -- forkIO, MVars
import System.Exit (ExitCode(..))
import System.Process (runInteractiveCommand, waitForProcess, ProcessHandle)
import System.IO
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Data.Word
import Data.IORef

-- import qualified Graphics.UI.WX as WX
import Graphics.UI.WX
import Graphics.UI.WX (Prop(..), on)

type OnReceive = String -> IO()
wxExecProcess :: Window a -> String -> Int -> IORef Bool -> (ExitCode -> IO()) -> OnReceive -> OnReceive
              -> IO ProcessHandle
-- if the user needs to give input to the created process, we could return IO (String -> IO StreamStatus) in stead
wxExecProcess parent cmd bufferSize killedByUser onEndProcess onOutput onErrOutput =
    do (inh,outh,errh,pid) <- runInteractiveCommand cmd
       mapM_ (\hdl -> hSetBuffering hdl NoBuffering) [inh, outh, errh]

       -- fork off two threads to start consuming the stdout and stderr output
       stdOutMVar       <- newEmptyMVar
       stdErrMVar       <- newEmptyMVar
       stdOutIsFinished <- newEmptyMVar
       stdErrIsFinished <- newEmptyMVar
       processFinished  <- newEmptyMVar

       let consume handle isFinished outputMVar =
               do buf <- mallocArray bufferSize
                  consume' handle isFinished outputMVar buf
                  free buf

           consume' handle isFinished outputMVar buf =
               do outIsEOF <- hIsEOF handle
                  if outIsEOF
                    then putMVar isFinished ()
                    else do hWaitForInput handle 1000   -- 1000 = one second
                            count <- hGetBufNonBlocking handle buf bufferSize
                            (x :: [Word8]) <- peekArray count buf
                            putMVar outputMVar (map (toEnum . fromIntegral) x)
                            consume' handle isFinished outputMVar buf

       forkIO $ consume outh stdOutIsFinished stdOutMVar
       forkIO $ consume errh stdErrIsFinished stdErrMVar

       let handleAnyInput mvar withOutput =
               do val <- tryTakeMVar mvar
                  maybe (return ()) withOutput val

       let handleAllInput = do handleAnyInput stdOutMVar onOutput
                               handleAnyInput stdErrMVar onErrOutput

       checkOutput <- timer parent [ interval := 100 ] -- 10 times a second
       set checkOutput [ on command := do
                           exitCode <- tryTakeMVar processFinished
                           handleAllInput
                           case exitCode of
                             Nothing   -> return ()
                             Just code -> do onEndProcess code
                                             set checkOutput [enabled := False]
                       ]

       forkIO $ do exitCode <- waitForProcess pid -- compile with -threaded to allow other threads to be active concurrently!
                   wasKilled <- varGet killedByUser
                   let waitForOutputs = mapM_ takeMVar [stdOutIsFinished, stdErrIsFinished]
                       signalFinished = putMVar processFinished exitCode
                   if wasKilled
                      then do signalFinished; waitForOutputs
                      else do waitForOutputs; signalFinished
                   hClose outh
                   hClose errh

       return pid