wxcore-0.92.3.0: src/haskell/Graphics/UI/WXCore/Process.hs
-----------------------------------------------------------------------------------------
{-|
Module : Process
Copyright : (c) Daan Leijen 2003
License : wxWindows
Maintainer : wxhaskell-devel@lists.sourceforge.net
Stability : provisional
Portability : portable
Process and stream wrappers.
-}
-----------------------------------------------------------------------------------------
module Graphics.UI.WXCore.Process
(
-- * Process
OnReceive, OnEndProcess
, processExecAsyncTimed, processExecAsync
-- * Streams
, StreamStatus(..)
, streamBaseStatus
-- * Blocking IO
, inputStreamGetContents
, inputStreamGetContentsN
, inputStreamGetLine
, inputStreamGetString
, inputStreamGetChar
, outputStreamPutString
-- * Non-blocking IO
, inputStreamGetLineNoWait
, inputStreamGetStringNoWait
, inputStreamGetCharNoWait
, outputStreamPutStringNoWait
) where
import System.IO.Unsafe( unsafeInterleaveIO )
import Graphics.UI.WXCore.WxcDefs
import Graphics.UI.WXCore.WxcClasses
import Graphics.UI.WXCore.Types
import Graphics.UI.WXCore.Events
import Foreign
import Foreign.C.String
import Foreign.C.Types
-- | Write a string to an output stream, potentially blocking
-- until all output has been written.
outputStreamPutString :: OutputStream a -> String -> IO ()
outputStreamPutString outputStream s
= withCString s $ \cstr -> write cstr (length s)
where
write cstr n
= do outputStreamWrite outputStream cstr n
m <- outputStreamLastWrite outputStream
if (m < n && m > 0 {- prevent infinite loop -} )
then write (advancePtr cstr m) (n - m)
else return ()
-- | Write a string to an output stream, returning the
-- number of bytes actually written.
outputStreamPutStringNoWait :: OutputStream a -> String -> IO Int
outputStreamPutStringNoWait outputStream s
= withCString s $ \cstr ->
do outputStreamWrite outputStream cstr (length s)
outputStreamLastWrite outputStream
-- | @inputStreamGetLineNoWait stream n@ reads a line of at most @n@ characters from the
-- input stream in a non-blocking way. The function does automatic end-of-line
-- conversion. If the line ends with @\\n@, an entire line
-- has been read, otherwise, either the maximum has been reached, or no more
-- input was available.
inputStreamGetLineNoWait :: InputStream a -> Int -> IO String
inputStreamGetLineNoWait inputStream maxChars
= readInputStream "" 0
where
readInputStream acc n
= if n >= maxChars
then return (reverse acc)
else do mbc <- inputStreamGetCharNoWait inputStream
case mbc of
Nothing -> return (reverse acc)
Just '\n' -> return (reverse ('\n':acc))
Just '\r' -> do mbc2 <- inputStreamGetCharNoWait inputStream
case mbc2 of
Just c2 | c2 /= '\n' -> inputStreamUngetch inputStream c2 >>
return ()
_ -> return ()
return (reverse ('\n':acc))
Just c -> readInputStream (c:acc) (n+1)
-- | @inputStreamGetStringNoWait stream n@ reads a line of at most @n@ characters from the
-- input stream in a non-blocking way.
inputStreamGetStringNoWait :: InputStream a -> Int -> IO String
inputStreamGetStringNoWait input maxChars
= readInputStream "" 0
where
readInputStream acc n
= if ( n >= maxChars )
then return (reverse acc)
else do mbc <- inputStreamGetCharNoWait input
case mbc of
Nothing -> return (reverse acc)
Just c -> readInputStream (c:acc) (n+1)
-- | Read a single character from the input, returning @Nothing@ if no input
-- was available (using 'inputStreamCanRead').
inputStreamGetCharNoWait :: InputStream a -> IO (Maybe Char)
inputStreamGetCharNoWait input
= do canRead <- inputStreamCanRead input
if canRead
then do c <- inputStreamGetC input
return (Just c)
else return Nothing
-- | @inputStreamGetLine s n@ reads a line of at most @n@ characters from the
-- input stream (potentially waiting for input). The function does automatic end-of-line
-- conversion. If the line ends with @\\n@, an entire line
-- has been read, otherwise, either the maximum has been reached, or no more
-- input was available.
inputStreamGetLine :: InputStream a -> Int -> IO String
inputStreamGetLine inputStream maxChars
= readInputStream "" 0
where
readInputStream acc n
= if n >= maxChars
then return (reverse acc)
else do c <- inputStreamGetChar inputStream
case c of
'\n' -> return (reverse ('\n':acc))
'\r' -> do mbc2 <- inputStreamGetCharNoWait inputStream
case mbc2 of
Just c2 | c2 /= '\n' -> inputStreamUngetch inputStream c2 >>
return ()
_ -> return ()
return (reverse ('\n':acc))
_ -> readInputStream (c:acc) (n+1)
-- | Read a single character from the input. (equals 'inputStreamGetC')
inputStreamGetChar :: InputStream a -> IO Char
inputStreamGetChar input
= inputStreamGetC input
-- | The expression (@inputStreamGetString n input@) reads a string of maximally
-- @n@ characters from @input@.
inputStreamGetString :: InputStream a -> Int -> IO String
inputStreamGetString inputStream n
= allocaBytes (n+1) $ \buffer ->
do inputStreamRead inputStream buffer n
nread <- inputStreamLastRead inputStream
mapM (peekChar buffer) [0..nread-1]
where
peekChar :: Ptr CChar -> Int -> IO Char
peekChar p ofs
= do cchar <- peekElemOff p ofs
return (castCCharToChar cchar)
-- | Get the entire contents of an input stream. The content
-- is returned as a lazy stream (like 'hGetContents').
inputStreamGetContents :: InputStream a -> IO String
inputStreamGetContents inputStream
= inputStreamGetContentsN inputStream 1
-- | Get the entire contents of an input stream. The content
-- is returned as a lazy stream (like 'hGetContents'). The
-- contents are returned in lazy /batches/, whose size is
-- determined by the first parameter.
inputStreamGetContentsN :: InputStream a -> Int -> IO String
inputStreamGetContentsN inputStream n
= do status <- streamBaseGetLastError inputStream
if (status == wxSTREAM_NO_ERROR)
then do x <- inputStreamGetString inputStream n
xs <- unsafeInterleaveIO (inputStreamGetContentsN inputStream n)
return (x ++ xs)
else return ""
-- | Return the status of the stream
streamBaseStatus :: StreamBase a -> IO StreamStatus
streamBaseStatus stream
= do code <- streamBaseGetLastError stream
return (streamStatusFromInt code)
-- | Type of input receiver function.
type OnReceive = String -> StreamStatus -> IO ()
-- | Type of end-of-process event handler. Gets the exitcode as its argument.
type OnEndProcess = Int -> IO ()
-- | (@processExecAsyncTimer command processOutputOnEnd onEndProcess onOutput onErrorOutput parent@) starts
-- the @command@ asynchronously. The handler @onEndProcess@ is called when the process
-- terminates. @onOutput@ receives the output from @stdout@, while @onErrorOutput@ receives
-- output from @stderr@. If @processOutputOnEnd@ is 'True', the remaining output of a terminated
-- process is processed (calling @onOutput@). The call returns a triple (@send,process,pid@):
-- The @send@ function is used to send input to the @stdin@ pipe of the process. The
-- process object is returned in @process@ and the process identifier in @pid@.
--
-- Note: The method uses idle event timers to process the output channels. On
-- many platforms this is much more trustworthy and robust than the 'processExecAsync' that
-- uses threads (which can cause all kinds of portability problems).
processExecAsyncTimed :: Window a -> String -> Bool -> OnEndProcess -> OnReceive -> OnReceive
-> IO (String -> IO StreamStatus, Process (), Int)
processExecAsyncTimed parent cmd readInputOnEnd onEndProcess onOutput onErrOutput
= do process <- processCreateDefault parent idAny
processRedirect process
pid <- wxcAppExecuteProcess cmd wxEXEC_ASYNC process
if (pid == 0)
then return (\_s -> return StreamEof, objectNull, pid)
else do v <- varCreate (Just process)
windowOnIdle parent (handleAnyInput v)
unregister <- appRegisterIdle 100 -- 10 times a second
evtHandlerOnEndProcess parent (handleTerminate v unregister)
let send txt = handleSend v txt
return (send, process, pid)
where
maxLine :: Int
maxLine = 160
handleSend :: Var (Maybe (Process a)) -> String -> IO StreamStatus
handleSend v txt
= withProcess v StreamEof $ \process ->
do outputPipe <- processGetOutputStream process
outputStreamPutString outputPipe txt -- TODO: use idle events to do output non-blocking?
streamBaseStatus outputPipe
handleAnyInput :: Var (Maybe (Process a)) -> IO Bool
handleAnyInput v
= withProcess v False $ \process ->
do inputPipe <- processGetInputStream process
available <- handleInput inputPipe onOutput -- process some input on stdout
errorPipe <- processGetErrorStream process
handleAllInput errorPipe onErrOutput -- process all input on stderr
return available
handleAllInput :: InputStream a -> OnReceive -> IO ()
handleAllInput input onOutput'
= do available <- handleInput input onOutput'
if (available)
then handleAllInput input onOutput'
else return ()
handleInput :: InputStream a -> OnReceive -> IO Bool
handleInput input onOutput'
= do txt <- inputStreamGetLineNoWait input maxLine
status <- streamBaseStatus input
if null txt
then case status of
StreamOk -> return False
_ -> do onOutput' "" status
return False
else do onOutput' txt status
return True
handleTerminate :: Var (Maybe (Process a)) -> IO () -> Int -> Int -> IO ()
handleTerminate v unregister _pid exitCode
= do unregister
withProcess v () $ \process ->
do varSet v Nothing
if (readInputOnEnd)
then do inputPipe <- processGetInputStream process
handleAllInput inputPipe onOutput -- handle remaining input
else return ()
onEndProcess exitCode
processDelete process
return ()
withProcess v x f
= do mb <- varGet v
case mb of
Nothing -> return x
Just p -> f p
{-# DEPRECATED processExecAsync "Use processExecAsyncTimed instead (if possible)" #-}
-- | deprecated: use 'processExecAsyncTimed' instead (if possible).
-- (@processExecAsync command bufferSize onEndProcess onOutput onErrorOutput parent@) starts
-- the @command@ asynchronously. The handler @onEndProcess@ is called when the process
-- terminates. @onOutput@ receives the output from @stdout@, while @onErrorOutput@ receives
-- output from @stderr@. The @bufferSize@ determines the intermediate buffer used to
-- cache the output from those channels. The calls returns a triple (@send,process,pid@):
-- The @send@ function is used to send input to the @stdin@ pipe of the process. The
-- process object is returned in @process@ and the process identifier in @pid@.
processExecAsync :: Window a -> String -> Int -> OnEndProcess -> OnReceive -> OnReceive
-> IO (String -> IO (), Process (), Int)
processExecAsync parent command bufferSize onEndProcess onOutput onErrOutput
= do process <- processCreateDefault parent idAny
processRedirect process
pid <- wxcAppExecuteProcess command wxEXEC_ASYNC process
if (pid == 0)
then return (\_s -> return (), objectNull, pid)
else do inputPipe <- processGetInputStream process
outputPipe <- processGetOutputStream process
errorPipe <- processGetErrorStream process
evtHandlerOnEndProcess parent (handleOnEndProcess pid process inputPipe outputPipe errorPipe)
evtHandlerOnInput parent onOutput inputPipe bufferSize
evtHandlerOnInput parent onErrOutput errorPipe bufferSize
let send txt = outputStreamPutString outputPipe txt
return (send, process, pid)
where
handleOnEndProcess ourPid process _inputPipe _outputPipe _errorPipe pid exitcode
| ourPid == pid = do onEndProcess exitcode
processDelete process
| otherwise = return ()