packages feed

frpnow-gtk3 (empty) → 0.2.0

raw patch · 11 files changed

+878/−0 lines, 11 filesdep +basedep +containersdep +frpnowsetup-changed

Dependencies added: base, containers, frpnow, glib, gtk3, mtl, text

Files

+ Control/FRPNow/GTK.hs view
@@ -0,0 +1,27 @@++{-# LANGUAGE LambdaCase, RecursiveDo #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.FRPNow.GTK+-- Copyright   :  (c) George Steel 2017+-- License     :  BSD3+-- Maintainer  :  george.steel@gmail.org+--+-- This module gathers all functions in frpnow-gtk3++module Control.FRPNow.GTK(+    module Control.FRPNow.GTK.Core,+    module Control.FRPNow.GTK.Buttons,+    module Control.FRPNow.GTK.Containers,+    module Control.FRPNow.GTK.DataWidgets,+    module Control.FRPNow.GTK.TreeView,+    module Control.FRPNow.GTK.Misc+ ) where++import Control.FRPNow.GTK.Core+import Control.FRPNow.GTK.Buttons+import Control.FRPNow.GTK.DataWidgets+import Control.FRPNow.GTK.Containers+import Control.FRPNow.GTK.DataWidgets+import Control.FRPNow.GTK.TreeView+import Control.FRPNow.GTK.Misc
+ Control/FRPNow/GTK/Buttons.hs view
@@ -0,0 +1,116 @@+{- |+Module      :  Control.FRPNow.GTK.Buttons+Copyright   :  (c) George Steel 2017+License     :  BSD3+Maintainer  :  george.steel@gmail.org++Functions for creating buttons which interact with FRPNow.++-}++module Control.FRPNow.GTK.Buttons (+    IconName, createButton, createDynamicButton, createToggleButton,+    -- * Checkboxes+    createCheckButton, createStaticChecklist, createDynamicChecklist,+) where++import Control.FRPNow.GTK.Core+import Control.FRPNow.GTK.Containers+import Graphics.UI.Gtk+import Control.Applicative+import Control.Monad+import Control.FRPNow+import Data.Maybe+import qualified Data.Text as T+import Data.Text (Text)++-- | Type for standard icon names.+-- The value should be contained in the standard list at <https://developer.gnome.org/icon-naming-spec/>.+type IconName = T.Text++-- | Creates a button with (optionally) text and an icon. Returns the button and when it is pressed.+createButton :: Maybe IconName -> Maybe Text -> Now (Button, EvStream ())+createButton micon mlbl = do+    btn <- sync buttonNew+    iattr <- case micon of+        Just icon -> do+            img <- sync $ imageNewFromIconName icon IconSizeButton+            return [buttonImage := img]+        Nothing -> return []+    let tattr = maybeToList (fmap (buttonLabel :=) mlbl)+    sync $ set btn (iattr ++ tattr)+    pressed <- getUnitSignal buttonActivated btn+    return (btn, pressed)++-- | Creates a toggle button with an initial state. Breutns the button and it's current state.+createToggleButton :: Maybe IconName -> Maybe Text -> Bool -> Now (ToggleButton, Behavior Bool)+createToggleButton micon mlbl initstate = do+    btn <- sync toggleButtonNew+    iattr <- case micon of+        Just icon -> do+            img <- sync $ imageNewFromIconName icon IconSizeButton+            return [buttonImage := img]+        Nothing -> return []+    let tattr = maybeToList (fmap (buttonLabel :=) mlbl)+    sync $ set btn (iattr ++ tattr ++ [toggleButtonActive := initstate])+    updated <- getSignal toggled btn (toggleButtonGetActive btn >>=)+    st <- sample $ fromChanges initstate updated+    return (btn,st)++-- | Creates a button with dynamic text.+createDynamicButton :: Behavior Text -> Now (Button,EvStream ())+createDynamicButton s = do+    button <- sync buttonNew+    setAttr buttonLabel button s+    stream <- getUnitSignal buttonActivated button+    return (button,stream)++--------------------------------------------------------------------------------++-- | Creates a checkbox with text an an initial state. Returns the widget and its current state+createCheckButton :: Text -> Bool -> Now (CheckButton, Behavior Bool)+createCheckButton txt initstate = do+    btn <- sync $ checkButtonNewWithLabel txt+    sync $ set btn [toggleButtonActive := initstate]+    updated <- getSignal toggled btn (toggleButtonGetActive btn >>=)+    st <- sample $ fromChanges initstate updated+    return (btn,st)+++createChecklistItem :: (a, Text) -> Bool -> Now (CheckButton, Behavior [a])+createChecklistItem (val, txt) initstate = do+    (btn,st) <- createCheckButton txt initstate+    return (btn, fmap (\b -> if b then [val] else []) st)++-- | Creates a set of checkboxes from a list of (item,label) pairs and a list of initially-checked items. Returns a list of 'CheckButton's (use a function on the "Containers" module to pack them) and the currently-selected items.+createStaticChecklist :: Eq a => [(a,Text)] -> [a] -> Now ([CheckButton], Behavior [a])+createStaticChecklist items startchecked = do+    btns <- forM items $ \item@(val,txt) ->+        createChecklistItem item (val `elem` startchecked)+    let (cbs, results) = unzip btns+        vals = mconcat results+    return (cbs, vals)++-- | Creates a checklist to select from a dynamic list of objects (updating the displayed checkboxes). Returns the checklist (stacked vertically in a VBox) and the currently selected items.+createDynamicChecklist :: Eq a => Behavior [(a, Text)] -> Now (VBox, Behavior [a])+createDynamicChecklist dynitems = do+    box <- sync $ vBoxNew False 0+    inititems <- sample dynitems+    (initboxes,initselected) <- createStaticChecklist inititems []+    sync $ forM_ initboxes $ \cb -> boxPackStart box cb PackNatural 0++    let itemsChanged = toChanges dynitems+    (outReplaced,replaceOut) <- callbackStream+    selected <- sample $ foldrSwitch initselected outReplaced++    flip callStream itemsChanged $ \itemslist -> do+        let newitems = last itemslist+        oldselection <- sample selected+        sync $ clearChildren box+        (newboxes,newselected) <- createStaticChecklist newitems oldselection+        sync $ forM_ newboxes $ \cb -> boxPackStart box cb PackNatural 0+        sync $ widgetShowAll box+        sync $ replaceOut newselected+        return ()++    return (box,selected)
+ Control/FRPNow/GTK/Containers.hs view
@@ -0,0 +1,184 @@+{- |+Module      :  Control.FRPNow.GTK.Containers+Copyright   :  (c) George Steel 2017+License     :  BSD3+Maintainer  :  george.steel@gmail.org++EDSL for widget layouts ussing GTK container widgets.++Containers containing single children are created by actions taking the child widget as their last parameter, allowing for easy composition using '=<<'.+Containers taking multiple children take their contents as a reader monad which runs over the newly-created widget, allowing packing commands to insert children of heterogeneous types, possibly with options.+As all container-creation actions run in 'MonadIO', nesting containers can be done inline with standard monadic composition.++Given the wiegets foo, bar, baz, where foo supports scrolling (such as a TreeView) we can create a simple layout as follows++> layout <- createVBox 0 $ do+>     bstretch =<< createFrame ShadowIn =<< createScrolledWindow foo+>     bpack <=< createHBox 0 $ do+>         bpack bar+>         bspacer+>         bpack =<< set' [attr := val] baz++-}++module Control.FRPNow.GTK.Containers where++import Graphics.UI.Gtk+import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Control.Monad.IO.Class+import qualified Data.Text as T+import Data.Text (Text)++-- | Destroys all children in a container, leaving it empty+clearChildren :: (MonadIO m, ContainerClass w) => w -> m ()+clearChildren cont = liftIO $ do+    children <- containerGetChildren cont+    forM_ children widgetDestroy++-- | Sets aattributes on a widget and returns the widget. Useful for setting attributes inline in a composition chain.+set' :: (MonadIO m) => [AttrOp w] -> w -> m w+set' ops w = liftIO $ do+    set w ops+    return w++-- * Box++-- | Creates an HBox with a given spacing and fills it using the reader.+createHBox :: (MonadIO m) => Int -> ReaderT HBox IO a -> m HBox+createHBox spacing filler = liftIO $ do+    b <- hBoxNew False spacing+    runReaderT filler b+    return b++-- | Creates a VBox with a given spacing and fills it using the reader.+createVBox :: (MonadIO m) => Int -> ReaderT VBox IO a -> m VBox+createVBox spacing filler = liftIO $ do+    b <- vBoxNew False spacing+    runReaderT filler b+    return b++-- | Inserts a witget into the enclosing box as its natural size.+bpack :: (WidgetClass w, BoxClass b) => w -> ReaderT b IO ()+bpack w = ReaderT $ \b -> boxPackStart b w PackNatural 0++-- | Inserts a widget into the enclosing box with rubber length (takes all excess space).+bstretch :: (WidgetClass w, BoxClass b) => w -> ReaderT b IO ()+bstretch w = ReaderT $ \b -> boxPackStart b w PackGrow 0++-- | Inserts an expanding spacer into a box+bspacer :: (BoxClass b) => ReaderT b IO ()+bspacer = ReaderT $ \b -> do+    s <- hBoxNew False 0+    boxPackStart b s PackGrow 10+++-- * Grid++-- | Creates a Grid (with the given x and y spacing) and fills it using the reader.+createGrid :: (MonadIO m) => Int -> Int -> ReaderT Grid IO () -> m Grid+createGrid xspace yspace filler = liftIO $ do+    g <- gridNew+    gridSetRowSpacing g yspace+    gridSetColumnSpacing g xspace+    runReaderT filler g+    return g++-- | Inserts a widget into the enclosing Grid at the given (x,y) position.+gcell :: (WidgetClass w, GridClass g) => (Int,Int) -> w -> ReaderT g IO ()+gcell (x,y) w = ReaderT $ \g -> gridAttach g w x y 1 1++-- | Inserts a widget into the enclosign Grid spanning several cells, with position fiven by the first srgument and size given by the second.+gcellspan :: (WidgetClass w, GridClass g) => (Int,Int) -> (Int,Int) -> w -> ReaderT g IO ()+gcellspan (x,y) (dx,dy) w = ReaderT $ \g -> gridAttach g w x y dx dy+++-- * Stack++-- | Creates a Stack and fills it using the reader.+createStack :: (MonadIO m) => ReaderT Stack IO () -> m Stack+createStack filler = liftIO $ do+    s <- stackNew+    runReaderT filler s+    return s++-- | Adds an element to the enclosing Stack with the given key.+stackElem :: (WidgetClass w) => Text -> w -> ReaderT Stack IO ()+stackElem key w = ReaderT $ \s -> stackAddNamed s w key++-- | Adds an element to the enclosing Stack with the given key and title.+stackElemTitled :: (WidgetClass w) => Text -> Text -> w -> ReaderT Stack IO ()+stackElemTitled key title w = ReaderT $ \s -> stackAddTitled s w key title++-- | Creates a StackSwitcher for a given Stack+createStackSwitcher :: (MonadIO m) => Stack -> m StackSwitcher+createStackSwitcher s = liftIO $ do+    sw <- stackSwitcherNew+    stackSwitcherSetStack sw s+    return sw+++-- * Notebook++-- | Createa a Notebook and fills it using the reader.+createNotebook :: (MonadIO m) => ReaderT Notebook IO a -> m Notebook+createNotebook filler = liftIO $ do+    s <- notebookNew+    runReaderT filler s+    return s++-- | Add a tab to the enclosing Notebook with the given title+nbpage :: (WidgetClass w) => Text -> w -> ReaderT Notebook IO ()+nbpage lbl w = ReaderT $ \nb -> void (notebookAppendPage nb w lbl)+++-- * Scrolling++-- | Creates a ScrolledWindow around a widget supporting scrolling natively.+createScrolledWindow :: (MonadIO m, WidgetClass w) => w -> m ScrolledWindow+createScrolledWindow w = liftIO $ do+    scr <- scrolledWindowNew Nothing Nothing+    containerAdd scr w+    return scr++-- | Creates a ScrolledWindow and Vieqwport around a widget not supporting scrollign such as a Box or Grid.+createScrolledViewport :: (MonadIO m, WidgetClass w) => w -> m ScrolledWindow+createScrolledViewport w = liftIO $ do+    scr <- scrolledWindowNew Nothing Nothing+    scrolledWindowAddWithViewport scr w+    return scr+++-- * Misc++-- | Creates a frame around a widget with a given shadow type+createFrame :: (MonadIO m, WidgetClass w) => ShadowType -> w -> m Frame+createFrame shad w = liftIO $ do+    f <- frameNew+    frameSetShadowType f shad+    containerAdd f w+    return f++-- | Creates an Expander around a given widget. The Text and Bool parameters control the label of the expander and whether it starts expanded.+createExpander :: (MonadIO m, WidgetClass w) => Text -> Bool -> w -> m Expander+createExpander lbl startpos w = liftIO $ do+    ex <- expanderNew lbl+    expanderSetExpanded ex startpos+    containerAdd ex w+    return ex++-- | Creates an HPaned contsing two other widgets.+createHPaned :: (MonadIO m, WidgetClass w1, WidgetClass w2) => w1 -> w2 -> m HPaned+createHPaned l r = liftIO $ do+    p <- hPanedNew+    panedPack1 p l True False+    panedPack2 p r True False+    return p+-- | Creates a VPaned containing two other widgets.+createVPaned :: (MonadIO m, WidgetClass w1, WidgetClass w2) => w1 -> w2 -> m VPaned+createVPaned l r = liftIO $ do+    p <- vPanedNew+    panedPack1 p l True False+    panedPack2 p r True False+    return p
+ Control/FRPNow/GTK/Core.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE LambdaCase, RecursiveDo #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.FRPNow.GTK.Core+-- Copyright   :  (c) Atze van der Ploeg 2015, George Steel 2017+-- License     :  BSD3+-- Maintainer  :  george.steel@gmail.org+--+-- Core functions for inteoperability between GTK and FRPNow++module Control.FRPNow.GTK.Core (+    ffor,+    runNowGTK,+    setAttr,+    getUnrealize,+    getSignal,+    getSimpleSignal,+    getUnitSignal,+    getClock+) where++import Graphics.UI.Gtk+import Control.Applicative+import Control.Monad+import Control.FRPNow+import Data.Maybe+import Data.IORef+import Debug.Trace+import System.Mem.Weak+import System.Glib.GDateTime+import qualified Data.Text as T+import Data.Text (Text)++-- | Flipped version of fmap for defining trandformations inline.+ffor :: (Functor f) => f a -> (a -> b) -> f b+ffor = flip fmap++-- | Carry monoidial structure through Behaviors+instance Monoid a => Monoid (Behavior a) where+    mempty = pure mempty+    x `mappend` y = mappend <$> x <*> y+++-- | 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 ()++-- | Get an event that fires when a widget is destroyed. Useful for cutting off event streams with 'beforeEs'.+getUnrealize :: (WidgetClass w) => w -> Now (Event ())+getUnrealize w = do+    (e,cb) <- callback+    sync $ on w unrealize (cb ())+    return e++-- | Set a GTK attribute to a behavior. Each time the behavior changes the attribute is updated.+setAttr :: (WidgetClass w, Eq b) => ReadWriteAttr w a b -> w -> Behavior b -> Now ()+setAttr a w b =+     do i <- sample b+        sync $ set w [a := i]+        e <- getUnrealize w+        let updates = toChanges b `beforeEs` e+        callIOStream setEm updates+  where setEm i = set w [a := i]+++-- | 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 convert a signal with handler @(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++-- REMOVED: 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+-- The signal is automatically disconnected, when the event stream is garbage collected.+++-- | Get a clock that gives the time since the creation of the clock in seconds, and updates maximally even given number of seconds.++-- REMOVED: 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
+ Control/FRPNow/GTK/DataWidgets.hs view
@@ -0,0 +1,152 @@+{- |+Module      :  Control.FRPNow.GTK.DataWidgets+Copyright   :  (c) George Steel 2017+License     :  BSD3+Maintainer  :  george.steel@gmail.org++Functions for creating widgets allowing entry and display of variable data, reperesented as 'Behavior's+-}++module Control.FRPNow.GTK.DataWidgets where++import Control.FRPNow.GTK.Core+import Control.FRPNow.GTK.MissingFFI+import Graphics.UI.Gtk+import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.FRPNow+import Data.Maybe+import qualified Data.Text as T+import Data.Text (Text)++-- | Version of 'show' which outputs 'Text'+showtext :: (Show a) => a -> Text+showtext = T.pack . show++-- * Labels++-- | Creates a label containing static text+createLabel :: (MonadIO m) => Text -> m Label+createLabel t = liftIO $ do+    l <- labelNew (Just t)+    set l [miscXalign := 0]+    return l++-- | Creates a label containing dynamic text+createLabelDisplay :: Behavior Text -> Now Label+createLabelDisplay s = do+     l <- sync $ labelNew (Nothing :: Maybe Text)+     sync $ set l [miscXalign := 0, labelWrap := True]+     setAttr labelLabel l s+     return l++-- | Creates a TextView with editing disabled containing dynamic text. Useful for showing text too long for a Label.+createTextViewDisplay :: Behavior Text -> Now TextView+createTextViewDisplay dyntext = do+    tv <- sync textViewNew+    done <- getUnrealize tv+    buf <- sync $ textBufferNew Nothing+    inittext <- sample dyntext+    let updates = toChanges dyntext `beforeEs` done+    sync $ set buf [textBufferText := inittext]+    callIOStream (\x -> set buf [textBufferText := x]) updates+    sync $ textViewSetBuffer tv buf+    return tv++-- * Entry++-- | Creates an Entey with an initial value+createEntry :: String -> Now (Entry, Behavior String)+createEntry inittext = do+    entry <- sync $ entryNew+    sync $ set entry [entryText := inittext]+    edits <- getSignal editableChanged entry (entryGetText entry >>=)+    btext <- sample $ fromChanges inittext edits+    return (entry, btext)++-- | Creates an Entry which only allows characters satisfying as predicate. Useful for numeric entry.+createFilteredEntry :: (Char -> Bool) -> String -> Now (Entry, Behavior String)+createFilteredEntry f inittext = do+    entry <- sync $ entryNew+    sync $ set entry [entryText := filter f inittext]+    sync . mfix $ \cid ->+        entry `on` insertText $ \str pos -> do+            signalBlock cid+            pos' <- editableInsertText entry (filter f str) pos+            signalUnblock cid+            stopInsertText cid+            return pos'+    edits <- getSignal editableChanged entry (entryGetText entry >>=)+    btext <- sample $ fromChanges inittext edits+    return (entry, btext)++-- | Creates a floating-point SpinButton with range, step size, and initial value.+createSpinEntry :: (Double, Double) -> Double -> Double -> Now (SpinButton, Behavior Double)+createSpinEntry (a,b) stepsize initval = do+    sbtn <- sync $ spinButtonNewWithRange a b stepsize+    sync $ spinButtonSetValue sbtn initval+    (changes, changecb) <- callbackStream+    sync $ onValueSpinned sbtn (changecb =<< spinButtonGetValue sbtn)+    val <- sample $ fromChanges initval changes+    return (sbtn,val)++-- | Creates a integer SpinButton with range, step size, and initial value.+createIntSpinEntry :: (Int, Int) -> Int -> Int -> Now (SpinButton, Behavior Int)+createIntSpinEntry (a,b) stepsize initval = do+    sbtn <- sync $ spinButtonNewWithRange (fromIntegral a) (fromIntegral b) (fromIntegral stepsize)+    sync $ spinButtonSetValue sbtn (fromIntegral initval)+    (changes, changecb) <- callbackStream+    sync $ onValueSpinned sbtn (changecb =<< spinButtonGetValueAsInt sbtn)+    val <- sample $ fromChanges initval changes+    return (sbtn,val)++-- * Progress++-- | Creates a progress bar which displays an annotation and can optionally be disabled.+createProgressBar :: Behavior (Maybe (Double, Text)) -> Now ProgressBar+createProgressBar mprogress = do+    let isactive = fmap isJust mprogress+        position = fmap (maybe 0 fst) mprogress+        lbl = fmap (maybe T.empty snd) mprogress+    bar <- sync progressBarNew+    sync $ set bar [progressBarShowText := True]+    setAttr progressBarFraction bar position+    setAttr progressBarText bar lbl+    setAttr widgetSensitive bar isactive+    return bar++-- | Creates a progress bar which is always on and displays the progres value only.+createSimpleProgressBar :: Behavior Double -> Now ProgressBar+createSimpleProgressBar progress = do+    bar <- sync $ progressBarNew+    setAttr progressBarFraction bar progress+    return bar++-- | Creates a spinner which spins when its parameter is True.+createSpinner :: Behavior Bool -> Now Spinner+createSpinner b = do+    spn <- sync $ spinnerNew+    setAttr spinnerActive spn b+    return spn++-- * Sliders++-- | Creates a slider with range, step size, and initial value.+createSlider :: (Double, Double) -> Double -> Double -> Now (HScale, Behavior Double)+createSlider (a,b) stepsize initval = do+    slider <- sync $ hScaleNewWithRange a b stepsize+    sync $ set slider [rangeValue := initval]+    changed <- getSignal valueChanged slider (rangeGetValue slider >>=)+    val <- sample $ fromChanges initval changed+    return (slider,val)++-- | Creates a slider which displays a dynamic value and emits attempts by the user to change that value.+createMotorizedSlider :: (Double, Double) -> Double -> Behavior Double -> Now (HScale,EvStream Double)+createMotorizedSlider (a,b) stepsize dat = do+    i <- sample dat+    slider <- sync $ hScaleNewWithRange a b stepsize+    setAttr rangeValue slider dat+    stream <- getSignal changeValue slider (\f _ d -> f d >> return True)+    return (slider,stream)
+ Control/FRPNow/GTK/Misc.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE RecursiveDo #-}++{- |+Module      :  Control.FRPNow.GTK.Misc+Copyright   :  (c) George Steel 2017+License     :  BSD3+Maintainer  :  george.steel@gmail.org++Utility Functions which do not fit anywhere else in the package.++-}+module Control.FRPNow.GTK.Misc where++import Control.FRPNow.GTK.Core+import Graphics.UI.Gtk+import Graphics.UI.Gtk.General.StyleContext+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.FRPNow+import qualified Data.Text as T+import Data.Text (Text)+import System.IO+import Control.Exception+import Control.Concurrent+import Control.Concurrent.MVar++-- | Map an expensive computation over a 'Behavior' to WHNF in a background thread ('force' is useful to get deep evaluation). The output behavior will lag behind the input behavior and thus requires an initial value.+-- To control the running of the computation, this function also takes an event after which all changes are disregarded (can be provided by 'getUnrealize' to tie this ti widget lifetimes) and returns a boolean Behavior which indicated if a new result is currently pending.+mapBAsync :: (Eq a) => Event () -> b -> (a -> b) -> Behavior a -> Now (Behavior b, Behavior Bool)+mapBAsync stop yinit f xb = do+    xinit <- sample xb+    let xchanged = toChanges xb `beforeEs` stop+    (pendingSet, setPending) <- callbackStream+    (yset, sety) <- callbackStream+    pending <- sample $ fromChanges True (merge (False <$ yset) pendingSet)+    q <- sync $ newMVar xinit+    flip callStream xchanged $ \xs -> let+        x = last xs+        in sync $ tryTakeMVar q >> putMVar q x+    sync . forkIO . forever $ do+        x <- takeMVar q+        setPending True+        y <- evaluate (f x)+        sety y+        setPending False+    yb <- sample $ fromChanges yinit yset+    return (yb, pending)++-- | Filter an event so that it only resolves if it does so before a cutoff event.+beforeE :: Event a -> Event () -> Behavior (Event a)+beforeE ev cutoff = fmap join $ first (never <$ cutoff) (pure <$> ev)++-- | Disable a widget when the condition is true. Does not check the initial state iof the condition and assumes it to be False initially. This isso it can be used inside 'mfix' where the condition has not been defined yet..+setLockedFuturistic :: (WidgetClass w) => w -> Behavior Bool -> Now ()+setLockedFuturistic w lock = do+    done <- getUnrealize w+    let lockchange = toChanges lock `beforeEs` done+    callIOStream (widgetSetSensitive w . not) lockchange++-- | Run a FileChooserDialog without blocking and return an Evemnt containing the resulting selected path.+runFileChooserDialog :: FileChooserDialog -> Now (Event (Maybe FilePath))+runFileChooserDialog dialog = do+    (retev, cb) <- callback+    sync $ mdo+        conn <- on dialog response $ \resp -> do+            widgetHide dialog+            case resp of+                ResponseAccept -> do+                    mfn <- fileChooserGetFilename dialog+                    cb mfn+                _ -> cb Nothing+            signalDisconnect conn+        widgetShow dialog+    return retev++-- | Check any 'IOError's returned by the action so that they result in a 'Nothing' value.+checkIOError :: IO a -> IO (Maybe a)+checkIOError action = catch (fmap Just action) handler where+    handler :: IOError -> IO (Maybe a)+    handler _ = return Nothing++-- | Add CSS classes to a widget.+widgetAddClasses :: (MonadIO m, WidgetClass widget) => [Text] -> widget -> m widget+widgetAddClasses cs w = liftIO $ do+    sc <- widgetGetStyleContext w+    forM_ cs $ \c -> styleContextAddClass sc c+    return w
+ Control/FRPNow/GTK/MissingFFI.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      :  Control.FRPNow.GTK.MissingFFI+Copyright   :  (c) George Steel 2017+License     :  BSD3+Maintainer  :  george.steel@gmail.org++Missing but necessary 'Attr' definitions which have not nade it into gtk3hs yet.++-}++module Control.FRPNow.GTK.MissingFFI where++import Graphics.UI.Gtk+import Control.Monad+import qualified Data.Text as T+import System.Glib.GObject+import System.Glib.Attributes+import System.Glib.Properties++scrolledWindowOverlay :: ScrolledWindowClass self => Attr self Bool+scrolledWindowOverlay = newAttrFromBoolProperty "overlay-scrolling"++panedWideHandle :: PanedClass self => Attr self Bool+panedWideHandle = newAttrFromBoolProperty "wide-handle"++progressBarShowText :: ProgressBarClass self => Attr self Bool+progressBarShowText = newAttrFromBoolProperty "show-text"
+ Control/FRPNow/GTK/TreeView.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE RankNTypes #-}++{- |+Module      :  Control.FRPNow.GTK.TreeView+Copyright   :  (c) George Steel 2017+License     :  BSD3+Maintainer  :  george.steel@gmail.org++Functions for working with 'TreeView' and dynamic data.+-}++module Control.FRPNow.GTK.TreeView where++import Control.FRPNow.GTK.Core+import Graphics.UI.Gtk.General.Enums (Align(..))+import Graphics.UI.Gtk+import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Control.Monad.IO.Class+import Control.FRPNow+import Data.Maybe+import qualified Data.Text as T+import Data.Text (Text)++-- | Creates a TreeView displauying a dynamic list. The columns and cell renderers are defined using reader monads built from the other functions in this module.In this casem the cells must be polymorphic in the type of store they accept so as to ensure read-only behavior. Returns the TreeView and the curently-selected item.+createListDisplay :: (Eq a) => Behavior [a] -> (forall store . (TreeModelClass (store a), TypedTreeModelClass store) => ReaderT (TreeView, store a) IO b) -> Now (TreeView, Behavior (Maybe a))+createListDisplay datafeed filler = do+    tv <- sync $ treeViewNew+    initdata <- sample datafeed+    store <- sync $ listStoreNew initdata+    sync $ treeViewSetModel tv store+    sync $ runReaderT filler (tv,store)+    flip callStream (toChanges datafeed) $ \newdata' -> sync $ do+        let newdata = last newdata'+        listStoreClear store+        mapM_ (listStoreAppend store) newdata+    itemSelected <- getSignal cursorChanged tv $ \cb -> do+        mcur <- fst <$> treeViewGetCursor tv+        case mcur of+            [i] -> do+                x <- listStoreGetValue store i+                cb (Just x)+            _ -> cb Nothing+    selItem <- sample $ fromChanges Nothing itemSelected+    return (tv,selItem)++-- | Add a column with the given title and renderers to the enclosing TreeView.+tvColumn :: Text -> ReaderT (TreeViewColumn, store) IO b -> ReaderT (TreeView, store) IO TreeViewColumn+tvColumn title filler = ReaderT $ \(tv,model) -> do+    col <- treeViewColumnNew+    set col [treeViewColumnTitle := title]+    runReaderT filler (col,model)+    treeViewAppendColumn tv col+    return col++-- | Add a cell renderer diaplaying a text-valued function of a row to a column.+tvTextDisplay :: (CellLayoutClass col, TreeModelClass (store a), TypedTreeModelClass store) => (a -> Text) -> ReaderT (col, store a) IO CellRendererText+tvTextDisplay f = ReaderT $ \(col,model) -> do+    cell <- cellRendererTextNew+    set cell [cellTextEditable := False]+    cellLayoutPackStart col cell True+    cellLayoutSetAttributes col cell model $ \row -> [cellText := f row]+    return cell++-- | Add a cell renderer diaplaying a s function of a row using Show. Useful for Int values.+tvShowDisplay :: (CellLayoutClass col, TreeModelClass (store a), TypedTreeModelClass store, Show b) => (a -> b) -> ReaderT (col, store a) IO CellRendererText+tvShowDisplay f = ReaderT $ \(col,model) -> do+    cell <- cellRendererTextNew+    set cell [cellTextEditable := False]+    cellLayoutPackStart col cell True+    cellLayoutSetAttributes col cell model $ \row -> [cellText := show (f row)]+    return cell
+ LICENSE view
@@ -0,0 +1,37 @@+Copyright (c) 2017, George Steel++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * 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.+    * Neither the name of the copyright holder nor the+      names of the contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++--------------------------------------------------------------------------------+The module Control.FRPNow.GTK.Core is based on the package frpnow-gtk which bears the following license:++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ frpnow-gtk3.cabal view
@@ -0,0 +1,35 @@+Name:                frpnow-gtk3+Version:             0.2.0+Synopsis:	         Program GUIs with GTK3 and frpnow!+Description:         High-level interface for GTK3 with FRPNow integration. The module "Control.FRPNow.GTK.Core" is a port of the original frpnow-gtk package providing low-level interop getween GTK and FRPNow while the other modules provide high-level UI functionality with FRPNow integration already built in.+License:             BSD3+License-file:        LICENSE+Author:              George Steel, Atze van der Ploeg+Maintainer:          george.steel@gmail.com+Homepage:            https://github.com/george-steel/frpnow-gtk3+Build-Type:          Simple+Cabal-Version:       >=1.10+Category:            UI+Tested-With:         GHC==7.10.1++Library+  default-language:  Haskell2010+  Build-Depends:     base >= 4.9 && <= 6+                   , mtl >= 2.0+                   , containers == 0.5.*+                   , frpnow == 0.18+                   , glib+                   , gtk3+                   , text == 1.2.*+  Exposed-modules:   Control.FRPNow.GTK+                   , Control.FRPNow.GTK.Core+                   , Control.FRPNow.GTK.Buttons+                   , Control.FRPNow.GTK.Containers+                   , Control.FRPNow.GTK.DataWidgets+                   , Control.FRPNow.GTK.TreeView+                   , Control.FRPNow.GTK.Misc+                   , Control.FRPNow.GTK.MissingFFI++source-repository head+    type:     git+    location: https://github.com/george-steel/frpnow-gtk3