module Manatee.Toolkit.Gtk.Concurrent where
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Graphics.UI.Gtk
import Manatee.Toolkit.General.STM
import qualified Control.Exception as Exc
data ViewChannel a =
ViewChannel {viewChannel :: TChan a
,viewChannelLock :: TVar Bool}
forkGuiIO :: IO a -> (a -> IO ()) -> IO (MVar a, ThreadId, ThreadId)
forkGuiIO calcAction guiAction = do
signal <- newEmptyMVar
calcThreadId <- forkIO $ calcAction >>= putMVar signal
guiThreadId <- onGuiSignal signal guiAction
return (signal, calcThreadId, guiThreadId)
forkGuiIO_ :: IO a -> (a -> IO ()) -> IO ()
forkGuiIO_ calcAction guiAction =
forkGuiIO calcAction guiAction
>> return ()
onGuiSignal :: MVar a -> (a -> IO ()) -> IO ThreadId
onGuiSignal signal guiAction =
forkIO $ takeMVar signal >>= postGUIAsync . guiAction
createViewChannel :: WidgetClass widget
=> TChan a
-> widget
-> IO (ViewChannel a)
createViewChannel channel widget = do
chan <- dupTChanIO channel
lock <- newTVarIO True
widget `onDestroy` writeTVarIO lock False
return $ ViewChannel chan lock
listenViewChannel :: ViewChannel a -> (a -> IO ()) -> IO ()
listenViewChannel vChannel@(ViewChannel {viewChannel = channel
,viewChannelLock = channelLock})
action = do
forkIO $
readTChanIO channel
>>= \x -> do
isLive <- readTVarIO channelLock
when isLive $
postGUIAsync $
Exc.catch
(do
action x
listenViewChannel vChannel action)
(\ (_ :: Exc.SomeException) ->
putStrLn "listenViewChannel : Catch exception, stop read broadcast channel.")
return ()
listenBufferChannel :: TChan a -> (a -> IO ()) -> IO ()
listenBufferChannel channel action = do
forkIO $
readTChanIO channel
>>= \x ->
postGUIAsync $
Exc.catch
(do
action x
listenBufferChannel channel action)
(\ (_ :: Exc.SomeException) ->
putStrLn "listenBufferChannel : Catch exception, stop read broadcast channel.")
return ()