diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,1 @@ +0.1 Initial version diff --git a/Control/FRPNow/GTK.hs b/Control/FRPNow/GTK.hs new file mode 100644 --- /dev/null +++ b/Control/FRPNow/GTK.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.FRPNow.GTK +-- Copyright : (c) Atze van der Ploeg 2015 +-- License : BSD-style +-- Maintainer : atzeus@gmail.org +-- Stability : provisional +-- Portability : portable +-- +-- This module provides interoperability of FRPNow and the GTK system. + +module Control.FRPNow.GTK( + -- * General interface + runNowGTK, setAttr, getSignal, getUnitSignal, getSimpleSignal, getClock, + -- * Utility functions + createLabel, createButton, createProgressBar,createSlider + ) where + +import Graphics.UI.Gtk +import Control.FRPNow +import Data.Maybe +import Data.IORef +import Debug.Trace +import System.Mem.Weak +import System.Glib.GDateTime + +-- | Run a Now computation which can interact with GTK. Also starts the GTK system. +-- Call only once, or GTK will freak out. +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 () + +-- | Set a GTK attribute to a behavior. Each time the behavior changes the +-- attribute is updated. +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 + + +-- | Obtain an event stream from a unit GTK signal, i.e. a signal with handler type: +-- +-- > IO () +getUnitSignal :: GObjectClass widget => Signal widget (IO ()) -> widget -> Now (EvStream ()) +getUnitSignal s w = getSignal s w (\f -> f ()) + + +-- | Obtain an event stream from a GTK signal giving a single value. +getSimpleSignal :: GObjectClass widget => Signal widget (value -> IO ()) -> widget -> Now (EvStream value) +getSimpleSignal s w = getSignal s w id + + +-- | General interface to convert an GTK signal to an event stream. +-- +-- The signal has type @callback@, for example @(ScrollType -> Double -> IO Bool)@ +-- and the eventstream gives elements of type @value@, for instance @(ScrollType,Double)@ +-- The conversion function (3rd argument) takes a function to call for producing the value +-- in our example, a function of type @(ScollType,Double) -> IO ()@ and produces +-- a function of the form @callback@, in our example @(ScrollType -> Double -> IO Bool)@. +-- +-- In this example we can covert a signal with hander @(ScrollType -> Double -> IO Bool)@ +-- to an eventstream giving elements of type @(ScrollType,Double)@ by letting the handler return @False@ +-- as follows: +-- +-- > scrollToEvStream :: Signal widget (ScrollType -> Double -> IO Bool) -> widget -> Now (EvStream (ScrollType,Double)) +-- > scrollToEvStream s w = getSignal s w convert where +-- > convert call scrolltype double = do call (scrolltype, double) +-- > return False +-- +-- The signal is automatically disconnected, when the event stream is garbage collected. +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) + --sync $ addFinalizer res (putStrLn "Run final" >> signalDisconnect conn) + return res + + +-- | Get a clock that gives the time since the creation of the clock in seconds, and updates maximally even given numer of seconds. +-- +-- The clock is automatically destroyed and all resources associated with the clock are freed +-- when the behavior is garbage collected. +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) + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,10 @@ +Copyright (c) 2015, Atze van der Ploeg +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the Atze van der Ploeg nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/frpnow-gtk.cabal b/frpnow-gtk.cabal new file mode 100644 --- /dev/null +++ b/frpnow-gtk.cabal @@ -0,0 +1,22 @@ +Name: frpnow-gtk +Version: 0.1 +Synopsis: Program GUIs with GTK and frpnow! +Description: Program GUIs with GTK and frpnow! +License: BSD3 +License-file: LICENSE +Author: Atze van der Ploeg +Maintainer: atzeus@gmail.com +Homepage: https://github.com/atzeus/FRPNow +Build-Type: Simple +Cabal-Version: >=1.6 +Data-files: ChangeLog +Category: Control +Tested-With: GHC==7.10.1 +Library + Build-Depends: base >= 2 && <= 6, mtl >= 1.0, containers, transformers, frpnow, glib, gtk + Exposed-modules: Control.FRPNow.GTK + Extensions: RankNTypes, GADTs, CPP, EmptyDataDecls + +source-repository head + type: git + location: https://github.com/atzeus/FRPNow/FRPNow-GTK