packages feed

binding-gtk (empty) → 0.2

raw patch · 7 files changed

+210/−0 lines, 7 filesdep +basedep +binding-coredep +gtksetup-changed

Dependencies added: base, binding-core, gtk, mtl

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Gideon Sireling
+
+All rights reserved.
+
+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 Gideon Sireling nor the names of other
+      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 THE COPYRIGHT
+OWNER OR CONTRIBUTORS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ binding-gtk.cabal view
@@ -0,0 +1,24 @@+name:               binding-gtk
+version:            0.2
+cabal-version:      >= 1.6
+license:            BSD3
+license-file:       LICENSE
+author:             Gideon Sireling
+maintainer:         haskell@accursoft.org
+homepage:           http://code.accursoft.com/binding
+bug-reports:        http://code.accursoft.com/binding/issues
+synopsis:           Data Binding in Gtk2Hs
+build-type:         Simple
+category:           GUI, User Interfaces
+extra-source-files: demo/simple.hs demo/lists.hs, demo/in.txt
+description:        Bind mutable data and lists to Gtk2Hs widgets.
+                    Examples are provided by the included demo programs.
+
+library
+  build-depends:   base <5, gtk, binding-core, mtl
+  hs-source-dirs:  src
+  exposed-modules: Graphics.UI.Gtk.Binding
+
+source-repository head
+  type:     hg
+  location: https://bitbucket.org/accursoft/binding
+ demo/in.txt view
@@ -0,0 +1,1 @@+[Person {name = "Joe", age = 32, active = True},Person {name = "Fred", age = 50, active = False},Person {name = "Alice", age = 43, active = True}]
+ demo/lists.hs view
@@ -0,0 +1,44 @@+import Data.IORef
+import Control.Monad
+import Graphics.UI.Gtk
+
+import Data.Binding.List
+import Graphics.UI.Gtk.Binding
+
+data Person = Person {name::String, age::Int, active::Bool} deriving (Read, Show)
+
+main = do --read the input
+          f <- readFile "in.txt"
+          bl <- toBindingList $ read f :: IO (BindingList IORef Person)
+          --create widgits
+          initGUI
+          name' <- entryNew
+          age' <- spinButtonNewWithRange 0 120 1
+          active' <- checkButtonNew
+          --bind them
+          nav <- navigation bl $ Person "" 0 False
+          bindControl bl name name' entryText (\p n -> p {name = n})
+          bindControl bl (fromIntegral . age) age' spinButtonValue (\p a -> p {age = round a})
+          bindControl bl active active' toggleButtonActive (\p a -> p {active = a})
+          --arrange the widgits
+          table <- tableNew 3 2 True
+
+          zipWithM_ (\cap row -> do label <- labelNew $ Just cap
+                                    tableAttachDefaults table label 0 1 row (row+1))
+                    ["Name:", "Age:", "Active:"] [0..2]
+
+          zipWithM_ (\wid row -> tableAttachDefaults table wid 1 2 row (row+1))
+                    [toWidget name', toWidget age', toWidget active'] [0..2]
+
+          vBox <- vBoxNew False 0
+          boxPackStartDefaults vBox table
+          boxPackStartDefaults vBox nav
+          --create the main window
+          window <- windowNew
+          set window [containerChild := vBox, windowTitle := "Data Binding with Gtk2Hs"]
+          onDestroy window mainQuit
+          --start the application
+          widgetShowAll window
+          mainGUI
+          new <- fromBindingList bl
+          writeFile "out.txt" $ show new
+ demo/simple.hs view
@@ -0,0 +1,25 @@+import Data.IORef
+import Graphics.UI.Gtk
+
+import Data.Binding.Simple
+import Graphics.UI.Gtk.Binding
+
+main = do --create widgits
+          initGUI
+          text1 <- entryNew
+          text2 <- entryNew
+          --bind them
+          source <- newVar 0 :: IO (Source IORef Double)
+          bindTextEntry source text1
+          bindTextEntry source text2
+          --arrange the widgits
+          hBox <- hBoxNew True 0
+          boxPackStartDefaults hBox text1
+          boxPackStartDefaults hBox text2
+          --create the main window
+          window <- windowNew
+          set window [containerChild := hBox, windowTitle := "Data Binding with Gtk2Hs"]
+          onDestroy window mainQuit
+          --start the application
+          widgetShowAll window
+          mainGUI
+ src/Graphics/UI/Gtk/Binding.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleContexts #-}
+module Graphics.UI.Gtk.Binding where
+
+import Control.Monad
+import Control.Monad.Trans
+import Graphics.UI.Gtk
+
+import Data.Binding.List as B
+
+-- | Bind a 'Source' to a control.
+bindToControl :: Bindable b =>
+                 b a      -- ^ the binding source
+              -> (a -> d) -- ^ a function that extracts data from the source
+              -> c        -- ^ the target control
+              -> Attr c d -- ^ the attribute of the control to bind to
+              -> IO ()
+bindToControl source extract control attribute = bind source extract control (\c d -> set c [attribute := d])
+
+-- | Bind from a control to a 'Source'.
+-- The source is updated when the control loses focus.
+bindFromControl :: (WidgetClass c, Bindable b) =>
+                   c             -- ^ the control
+                -> Attr c d      -- ^ the attribute of the control to bind from
+                -> (a -> d -> a) -- ^ a function that applies data from the control to the source
+                -> b a           -- ^ the binding source
+                -> IO (ConnectId c)
+bindFromControl control attribute apply source =
+   control `on` focusOutEvent $ liftIO $ do d <- get control attribute
+                                            a <- readVar source
+                                            writeVar source (apply a d)
+                                            return False
+
+-- | Create a two-way data binding.
+bindControl :: (WidgetClass c, Bindable b) =>
+               b a           -- ^ the binding source
+            -> (a -> d)      -- ^ a function that extracts data from the source
+            -> c             -- ^ the control
+            -> Attr c d      -- ^ the attribute of the control to bind to
+            -> (a -> d -> a) -- ^ a function that applies data from the control to the source
+            -> IO (ConnectId c)
+bindControl source extract control attribute apply = do
+   bindToControl source extract control attribute
+   bindFromControl control attribute apply source
+
+-- | Create a simple two-way data binding for a 'Textual' control.
+bindTextEntry :: (Show a, Read a, EntryClass c, WidgetClass c, Bindable b) =>
+                  b a -- ^ the binding source
+               -> c   -- ^ the control
+               -> IO (ConnectId c)
+bindTextEntry source control = do
+   bindToControl source show control entryText
+   control `on` focusOutEvent $ liftIO $ do d <- get control entryText
+                                            writeVar source (read d)
+                                            return False
+
+-- | Create a set of navigation buttons for a binding list.
+navigation :: Variable v =>
+              BindingList v a -- ^ the binding list
+           -> a               -- ^ the default value for inserts
+           -> IO HButtonBox
+navigation bl new = do spin <- spinButtonNewWithRange 0 1 1
+                       let setRange = B.length bl >>= spinButtonSetRange spin 0 . fromIntegral . pred
+                       setRange
+                       afterValueSpinned spin $ spinButtonGetValueAsInt spin >>= seek bl >> return ()
+                       buttons <- forM [("<<", spinButtonSetValue spin 0)
+                                       ,(">>", spinButtonSpin spin SpinEnd 0)
+                                       ,("+", insert bl new >>= spinButtonSetValue spin . fromIntegral >> setRange)
+                                       ,("-", B.remove bl >>= spinButtonSetValue spin . fromIntegral >> setRange)]
+                                       $ \(l,c) -> do b <- buttonNewWithLabel l
+                                                      on b buttonActivated c
+                                                      return b
+
+                       --disable the delete button when there's only one element
+                       let del = last buttons
+                       del `on` buttonActivated $ do l <- B.length bl
+                                                     del `set` [widgetSensitive := l > 1]
+
+                       --inserting enables the delete button
+                       (buttons !! 2) `on` buttonActivated $ del `set` [widgetSensitive := True]
+
+                       box <- hButtonBoxNew
+                       containerAdd box spin
+                       mapM_ (containerAdd box) buttons
+                       return box