binding-core (empty) → 0.2

raw patch · 6 files changed

+294/−0 lines, 6 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, binding-core, random, stm

Files

LICENSE +30/−0
Setup.hs +2/−0
binding-core.cabal +33/−0
src/Data/Binding/List.hs +109/−0
src/Data/Binding/Simple.hs +58/−0
src/Data/Variable.hs +62/−0

+ 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-core.cabal view

@@ -0,0 +1,33 @@+name:           binding-core
+version:        0.2
+cabal-version:  >= 1.9.2
+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
+build-type:     Simple
+category:       GUI, User Interfaces
+description:    Bind mutable data and lists to IO objects.
+                Wrappers for binding to graphical widgets are provided by binding-gtk and binding-wx.
+
+library
+  build-depends:   base <5, stm
+  hs-source-dirs:  src
+  exposed-modules: Data.Binding.Simple, Data.Binding.List, Data.Variable
+
+test-suite hunit
+  type:            exitcode-stdio-1.0
+  main-is:         tests/HUnit.hs
+  build-depends:   base, binding-core, random, HUnit
+
+test-suite quickcheck
+  type:            exitcode-stdio-1.0
+  main-is:         tests/QuickCheck.hs
+  build-depends:   base, binding-core, QuickCheck
+
+source-repository head
+  type:     hg
+  location: https://bitbucket.org/accursoft/binding

+ src/Data/Binding/List.hs view

@@ -0,0 +1,109 @@+{-# LANGUAGE ExistentialQuantification #-}
+module Data.Binding.List (module Data.Binding.Simple, BindingList, toBindingList, fromBindingList, length, position, seek, seekBy, next, prev, remove', remove, insert', insert) where
+
+import Prelude hiding (length)
+import qualified Prelude as P
+import Control.Monad
+
+import Data.Binding.Simple
+
+-- | Binding List
+data BindingList v a = Variable v => BindingList {source :: Source v a -- ^ the list's binding source
+                                                , list   :: v [v a]    -- ^ the bound list
+                                                , pos    :: v Int}     -- ^ the current position
+-- [v a] is itself in a Variable, to allow for insertions and deletions.
+
+-- | Create a binding list.
+toBindingList :: Variable v => [a] -> IO (BindingList v a)
+toBindingList [] = error "empty list"
+toBindingList list = do list'<- mapM newVar list >>= newVar
+                        source <- newVar (head list)
+                        pos <- newVar 0
+                        return $ BindingList source list' pos
+
+-- | Update the binding list from the 'source'.
+update :: BindingList v a -> IO ()
+update (BindingList source list pos) = do list' <- readVar list
+                                          pos' <- readVar pos
+                                          readVar source >>= writeVar (list' !! pos')
+
+-- | Extract the data from a binding list.
+fromBindingList :: Variable v => BindingList v a -> IO [a]
+fromBindingList b = do update b
+                       readVar (list b) >>= mapM readVar
+
+-- | interface to the binding list's 'Source'
+instance Variable v => Variable (BindingList v) where
+   {- WARNING warn "Did you mean to use newBindingList?" -}
+   newVar = warn where warn a = toBindingList [a]
+   readVar = readVar . source
+   writeVar = writeVar . source
+   modifyVar = modifyVar . source
+   modifyVar' = modifyVar' . source
+
+instance Variable v => Bindable (BindingList v) where
+   bind = bind . source
+
+-- | The size of a binding list.
+length :: Variable v =>  BindingList v a -> IO Int
+length b = do list <- readVar (list b)
+              return $ P.length list
+
+-- | Get the current position.
+position :: Variable v => BindingList v a -> IO Int
+position b = readVar $ pos b
+
+-- | Bind to a new position in a binding list.
+-- Returns the new position; this is convenient for 'seekBy' and friends.
+seek:: Variable v => BindingList v a -> Int -> IO Int
+seek b new = do pos' <- readVar $ pos b
+                if pos' == new then return new else update b >> seek' b new
+
+-- | Unconditional seek. Called after elements have changed position.
+seek':: BindingList v a -> Int -> IO Int
+seek' (BindingList source list pos) new = do list' <- readVar list
+                                             readVar (list' !! new) >>= writeVar source
+                                             writeVar pos new
+                                             return new
+
+-- | Bind to a new position in a binding list.
+seekBy :: Variable v => (Int -> Int) -> BindingList v a -> IO Int
+seekBy f bindingList = do pos <- readVar (pos bindingList)
+                          seek bindingList $ f pos
+
+-- | Bind to the next item in a binding list.
+next :: Variable v => BindingList v a -> IO Int
+next = seekBy succ
+
+-- | Bind to the previous item in a binding list.
+prev :: Variable v => BindingList v a -> IO Int
+prev = seekBy pred
+
+-- | Remove an element from a list.
+remove' :: [a] -> Int ->  [a]
+remove' list pos = let (xs, _:ys) = splitAt pos list
+                   in xs ++ ys
+
+-- | Remove the current element from the list.
+remove :: Variable v => BindingList v a -> IO Int
+remove b@(BindingList _ list pos) = do list' <- readVar list
+                                       pos' <- readVar pos
+                                       writeVar list $ remove' list' pos'
+                                       seek' b (if pos' == P.length list' - 1 then pos' - 1 else pos')
+
+-- | Insert an element into a list.
+insert' :: [a] -> Int -> a -> [a]
+insert' list pos x = let (xs, ys) = splitAt pos list
+                     in xs ++ [x] ++ ys
+
+-- | Insert an element into the list.
+-- The new element is inserted after the current element.
+-- This allows appending, but precludes prepending.
+insert :: Variable v => BindingList v a -> a -> IO Int
+insert b@(BindingList _ list pos) x = do update b
+                                         list' <- readVar list
+                                         pos' <- readVar pos
+                                         x' <- newVar x
+                                         let pos'' = pos' + 1
+                                         writeVar list $ insert' list' pos'' x'
+                                         seek' b pos''

+ src/Data/Binding/Simple.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE ExistentialQuantification #-}
+module Data.Binding.Simple (module Data.Variable, Bindable, bind, Source) where
+
+import Data.Variable
+
+-- | A data binding:
+-- @a@ is the type of the data source
+-- @a -> d@ is a function that extracts data from the source
+-- @t@ is the binding target
+-- @d -> t -> IO ()@ is a function that applies data to the target
+data Binding a = forall d t. Binding (a -> d) t (t -> d -> IO ())
+
+-- | Binding Source
+data Source v a = Variable v => Source {bindings :: v [Binding a] -- ^ the source'a bindings
+                                       ,var      :: v a}          -- ^ the bound variable
+
+-- | Update a single binding.
+update' :: a -> Binding a -> IO ()
+update' source (Binding extract target apply) = apply target $ extract source
+
+-- | Update a binding source's bindings.
+update :: Source v a -> IO ()
+update (Source bindings source) = do bindings <- readVar bindings
+                                     a <- readVar source
+                                     mapM_ (update' a) bindings
+
+instance Variable v => Variable (Source v) where
+   newVar a = do bindings <- newVar []
+                 v <- newVar a
+                 return $ Source bindings v
+
+   readVar = readVar . var
+
+   writeVar s a = writeVar (var s) a >> update s
+
+   modifyVar s f = modifyVar (var s) f >> update s
+
+   modifyVar' s f = do b <- modifyVar' (var s) f
+                       update s
+                       return b
+
+-- | Sources for data binding.
+class Variable b => Bindable b where
+   -- | Create a data binding.
+   bind :: b a               -- ^ the binding source
+        -> (a -> d)          -- ^ a function that extracts data from the source
+        -> t                 -- ^ the binding target
+        -> (t -> d -> IO ()) -- ^ a function that applies data to the target
+        -> IO ()
+
+instance Variable v => Bindable (Source v) where
+   bind (Source bindings var) extract target apply =
+      do let binding = Binding extract target apply
+         --update the new binding
+         a <- readVar var
+         update' a binding
+         --add the new binding to the list
+         modifyVar bindings (binding:)

+ src/Data/Variable.hs view

@@ -0,0 +1,62 @@+-- | Mutable variables in the IO Monad.
+module Data.Variable where
+
+import Data.IORef
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+
+class Variable v where
+   -- | Create a new variable.
+   newVar     :: a -> IO (v a)
+   -- | Read a variable.
+   readVar    :: v a -> IO a
+   -- | Write a variable.
+   writeVar   :: v a -> a -> IO ()
+   -- | Modify a variable.
+   modifyVar  :: v a -> (a -> a) -> IO ()
+   -- | Modify a variable, and return some value.
+   modifyVar' :: v a -> (a -> (a,b)) -> IO b
+
+instance Variable IORef where
+   newVar     = newIORef
+   readVar    = readIORef
+   writeVar   = writeIORef
+   modifyVar  = modifyIORef
+   modifyVar' = atomicModifyIORef
+
+instance Variable MVar where
+   newVar         = newMVar
+   readVar        = takeMVar
+   writeVar       = putMVar
+   modifyVar v f  = modifyMVar_ v (return . f)
+   modifyVar' v f = modifyMVar v (return . f)
+
+instance Variable TVar where
+   newVar         = newTVarIO
+
+   readVar        = readTVarIO
+
+   writeVar v x   = atomically $ writeTVar v x
+
+   modifyVar v f  = atomically $ do x <- readTVar v
+                                    writeTVar v (f x)
+
+   modifyVar' v f = atomically $ do x <- readTVar v
+                                    let (x', y) = f x
+                                    writeTVar v x'
+                                    return y
+
+instance Variable TMVar where
+   newVar         = newTMVarIO
+
+   readVar v      = atomically $ takeTMVar v
+
+   writeVar v x   = atomically $ putTMVar v x
+
+   modifyVar v f  = atomically $ do x <- takeTMVar v
+                                    putTMVar v (f x)
+
+   modifyVar' v f = atomically $ do x <- takeTMVar v
+                                    let (x', y) = f x
+                                    putTMVar v x'
+                                    return y