module Control.FRPNow.GTK(
runNowGTK, setAttr, getSignal, getUnitSignal, getSimpleSignal, getClock,
createLabel, createButton, createProgressBar,createSlider
) where
import Graphics.UI.Gtk
import Control.Applicative
import Control.FRPNow
import Data.Maybe
import Data.IORef
import Debug.Trace
import System.Mem.Weak
import System.Glib.GDateTime
runNowGTK :: Now () -> IO ()
runNowGTK n = do initGUI
doneRef <- newIORef Nothing
initNow (schedule doneRef) (n >> return never)
mainGUI
schedule :: IORef (Maybe a) -> IO (Maybe a) -> IO ()
schedule ref m = postGUIAsync $
m >>= \x ->
case x of
Just _ -> writeIORef ref x
Nothing -> return ()
setAttr :: (WidgetClass w, Eq a) => Attr w a -> w -> Behavior a -> Now ()
setAttr a w b =
do i <- sample b
sync $ set w [a := i]
(e,cb) <- callback
sync $ on w unrealize ( cb ())
let updates = toChanges b `beforeEs` e
callIOStream setEm updates
where setEm i = set w [a := i] >> widgetQueueDraw w
getUnitSignal :: GObjectClass widget => Signal widget (IO ()) -> widget -> Now (EvStream ())
getUnitSignal s w = getSignal s w (\f -> f ())
getSimpleSignal :: GObjectClass widget => Signal widget (value -> IO ()) -> widget -> Now (EvStream value)
getSimpleSignal s w = getSignal s w id
getSignal :: GObjectClass widget => Signal widget callback -> widget -> ((value -> IO ()) -> callback) -> Now (EvStream value)
getSignal s w conv =
do (res,f) <- callbackStream
conn <- sync $ on w s (conv f)
return res
getClock :: Double -> Now (Behavior Double)
getClock precision =
do start <- sync $ gGetCurrentTime
(res,cb) <- callbackStream
wres<- sync $ mkWeakPtr res Nothing
let getDiff = do now <- gGetCurrentTime
let seconds = gTimeValSec now gTimeValSec start
let microsec = gTimeValUSec now gTimeValUSec start
return $ (fromIntegral seconds) + (fromIntegral microsec) * 0.000001
let onTimeOut =
deRefWeak wres >>= \x ->
case x of
Just _ -> getDiff >>= cb >> return True
Nothing -> return False
sync $ timeoutAdd onTimeOut (round (precision * 1000))
sample $ fromChanges 0 res
createLabel :: Behavior String -> Now Label
createLabel s =
do l <- sync $ labelNew (Nothing :: Maybe String)
setAttr labelLabel l s
return l
createButton :: Behavior String -> Now (Button,EvStream ())
createButton s =
do button <- sync $ buttonNew
setAttr buttonLabel button s
stream <- getUnitSignal buttonActivated button
return (button,stream)
createProgressBar :: Now (ProgressBar, Double -> IO ())
createProgressBar =
do (evs, cb) <- callbackStream
progress <- sample $ fromChanges 0 evs
bar <- sync $ progressBarNew
setAttr progressBarFraction bar progress
return (bar,cb)
createSlider :: Double -> Double -> Double -> Behavior Double -> Now (HScale,EvStream Double)
createSlider min max step b =
do i <- sample b
slider <- sync $ hScaleNewWithRange min max step
setAttr rangeValue slider b
stream <- getSignal changeValue slider (\f _ d -> f d >> return True)
return (slider,stream)