reactive-banana-gi-gtk (empty) → 0.1.0.0
raw patch · 5 files changed
+379/−0 lines, 5 filesdep +basedep +gi-gtkdep +haskell-gi-basesetup-changed
Dependencies added: base, gi-gtk, haskell-gi-base, reactive-banana, reactive-banana-gi-gtk, text, transformers
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- reactive-banana-gi-gtk.cabal +40/−0
- src/Reactive/Banana/GI/Gtk.hs +311/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ reactive-banana-gi-gtk.cabal view
@@ -0,0 +1,40 @@+name: reactive-banana-gi-gtk+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: PublicDomain+license-file: LICENSE+maintainer: mrobinson7627@gmail.com+homepage: https://github.com/mr/reactive-banana-gi-gtk+synopsis: Simple reactive programming with GTK GObject Introspection+description:+ Create Events and Behaviors from GTK signals and attributes. Also supports sinking to attributes.+category: Development+author: Matthew Robinson++source-repository head+ type: git+ location: https://github.com/mr/reactive-banana-gi-gtk.git++library+ exposed-modules:+ Reactive.Banana.GI.Gtk+ build-depends:+ base >=4.7 && <5,+ reactive-banana >=1.1.0.1 && <1.2,+ gi-gtk >=3.0.11 && <3.1,+ haskell-gi-base ==0.20.*,+ transformers >=0.5.2.0 && <0.6,+ text >=1.2.2.1 && <1.3+ default-language: Haskell2010+ hs-source-dirs: src++test-suite reactive-banana-gi-gtk-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-depends:+ base >=4.9.1.0 && <4.10,+ reactive-banana-gi-gtk >=0.1.0.0 && <0.2+ default-language: Haskell2010+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ src/Reactive/Banana/GI/Gtk.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Reactive.Banana.GI.Gtk+ ( BuilderCastException(..)+ , castB+ , signalAddHandler+ , signalEN+ , signalE0+ , signalE1+ , propE+ , propB+ , sink+ , AttrOpBehavior(..)+ ) where++import Reactive.Banana+import Reactive.Banana.Frameworks++import Data.Typeable+import Control.Exception+import Control.Monad.IO.Class+import Data.Maybe (fromJust)+import qualified Data.Text as T+import Data.Text (Text)+import GHC.TypeLits++import Data.GI.Base+import Data.GI.Base.Attributes+ ( AttrLabelProxy(..)+ , AttrInfo(..)+ , AttrLabel(..)+ , AttrGetC(..)+ , AttrOpAllowed(..)+ , AttrOpTag(..)+ )++import Data.GI.Base.Overloading+ ( ResolveAttribute(..)+ , HasAttributeList(..)+ )++import Data.GI.Base.Signals+ ( SignalInfo(..)+ , GObjectNotifySignalInfo(..)+ )+import GI.Gtk+ ( GObject+ , IsBuilder+ , builderGetObject+ , get+ )+import Data.GI.Base.ManagedPtr (unsafeCastTo)++-- | Thown when 'castB' fails get an object+data BuilderCastException = UnknownIdException String+ deriving (Show, Typeable)++instance Exception BuilderCastException++-- | Shortcut for getting 'Data.GI.Base.GObject' from a Builder+--+-- @+-- stack <- castB builder "stack" Stack+-- @+castB+ :: (IsBuilder a, GObject o, MonadIO m)+ => a+ -> Text+ -> (ManagedPtr o -> o)+ -> m o+castB builder ident gtype =+ liftIO $ do+ o <- builderGetObject builder ident+ case o of+ Just a -> unsafeCastTo gtype a+ Nothing ->+ throw $ UnknownIdException $ T.unpack ident++signalAddHandler+ ::+ ( SignalInfo info+ , GObject self+ )+ => self+ -> SignalProxy self info+ -> ((a -> IO ()) -> HaskellCallbackType info)+ -> IO (AddHandler a)+signalAddHandler self signal f = do+ (addHandler, fire) <- newAddHandler+ on self signal (f fire)+ return addHandler++-- | Create an 'Reactive.Banana.Event' from+-- a 'Data.GI.Base.Signals.SignalProxy'. For making signalE# functions.+-- Provides the fire method from 'Reactive.Banana.Frameworks.newAddHandler'+-- for creating a callback.+signalEN+ ::+ ( SignalInfo info+ , GObject self+ )+ => self+ -> SignalProxy self info+ -> ((a -> IO ()) -> HaskellCallbackType info)+ -> MomentIO (Event a)+signalEN self signal f = do+ addHandler <- liftIO $ signalAddHandler self signal f+ fromAddHandler addHandler++-- | Get an 'Reactive.Banana.Event' from+-- a 'Data.GI.Base.Signals.SignalProxy' that produces nothing.+--+-- @+-- destroyE <- signalE1 window #destroy+-- @+signalE0+ ::+ ( HaskellCallbackType info ~ IO ()+ , SignalInfo info+ , GObject self+ )+ => self+ -> SignalProxy self info+ -> MomentIO (Event ())+signalE0 self signal = signalEN self signal ($ ())++-- | Get an 'Reactive.Banana.Event' from+-- a 'Data.GI.Base.Signals.SignalProxy' that produces one argument.+signalE1+ ::+ ( HaskellCallbackType info ~ (a -> IO ())+ , SignalInfo info+ , GObject self+ )+ => self+ -> SignalProxy self info+ -> MomentIO (Event a)+signalE1 self signal = signalEN self signal id++-- | Get an 'Reactive.Banana.Event' from+-- a 'Data.GI.Base.Attributes.AttrLabelProxy' that produces one argument.+propE+ ::+ ( GObject self+ , AttrGetC info self attr result+ , KnownSymbol (AttrLabel info)+ )+ => self+ -> AttrLabelProxy (attr :: Symbol)+ -> MomentIO (Event result)+propE self attr = do+ e <- signalE1 self (PropertyNotify attr)+ (const $ get self attr) `mapEventIO` e++-- | stepper on 'propE'+propB+ ::+ ( GObject self+ , AttrGetC info self attr result+ , KnownSymbol (AttrLabel info)+ )+ => self+ -> AttrLabelProxy (attr :: Symbol)+ -> MomentIO (Behavior result)+propB self attr = do+ e <- propE self attr+ initV <- get self attr+ stepper initV e++-- | Alternative to 'Data.GI.Base.Attributes.AttrOp' for use with 'sink'.+-- Accepts a 'Reactive.Banana.Behavior' and a GTK Attribute+data AttrOpBehavior self tag where+ (:==)+ ::+ ( HasAttributeList self+ , info ~ ResolveAttribute attr self+ , AttrInfo info+ , AttrBaseTypeConstraint info self+ , AttrOpAllowed tag info self+ , AttrSetTypeConstraint info b+ )+ => AttrLabelProxy (attr :: Symbol)+ -> Behavior b+ -> AttrOpBehavior self tag++ (:==>)+ ::+ ( HasAttributeList self+ , info ~ ResolveAttribute attr self+ , AttrInfo info+ , AttrBaseTypeConstraint info self+ , AttrOpAllowed tag info self+ , AttrSetTypeConstraint info b+ )+ => AttrLabelProxy (attr :: Symbol)+ -> Behavior (IO b)+ -> AttrOpBehavior self tag++ (:~~)+ ::+ ( HasAttributeList self+ , info ~ ResolveAttribute attr self+ , AttrInfo info+ , AttrBaseTypeConstraint info self+ , tag ~ AttrSet+ , AttrOpAllowed AttrSet info self+ , AttrOpAllowed AttrGet info self+ , AttrSetTypeConstraint info b+ , a ~ AttrGetType info+ )+ => AttrLabelProxy (attr :: Symbol)+ -> Behavior (a -> b)+ -> AttrOpBehavior self tag++ (:~~>)+ ::+ ( HasAttributeList self+ , info ~ ResolveAttribute attr self+ , AttrInfo info+ , AttrBaseTypeConstraint info self+ , tag ~ AttrSet+ , AttrOpAllowed AttrSet info self+ , AttrOpAllowed AttrGet info self+ , AttrSetTypeConstraint info b+ , a ~ AttrGetType info+ )+ => AttrLabelProxy (attr :: Symbol)+ -> Behavior (a -> IO b)+ -> AttrOpBehavior self tag++ (::==)+ ::+ ( HasAttributeList self+ , info ~ ResolveAttribute attr self+ , AttrInfo info+ , AttrBaseTypeConstraint info self+ , tag ~ AttrSet+ , AttrOpAllowed tag info self+ , AttrSetTypeConstraint info b+ )+ => AttrLabelProxy (attr :: Symbol)+ -> Behavior (self -> b)+ -> AttrOpBehavior self tag++ (::~~)+ ::+ ( HasAttributeList self+ , info ~ ResolveAttribute attr self+ , AttrInfo info+ , AttrBaseTypeConstraint info self+ , tag ~ AttrSet+ , AttrOpAllowed AttrSet info self+ , AttrOpAllowed AttrGet info self+ , AttrSetTypeConstraint info b+ , a ~ AttrGetType info+ )+ => AttrLabelProxy (attr :: Symbol)+ -> Behavior (self -> a -> b)+ -> AttrOpBehavior self tag++infixr 0 :==+infixr 0 :==>+infixr 0 :~~+infixr 0 ::==+infixr 0 ::~~++sink1 :: GObject self => self -> AttrOpBehavior self AttrSet -> MomentIO ()+sink1 self (attr :== b) = do+ x <- valueBLater b+ liftIOLater $ set self [attr := x]+ e <- changes b+ reactimate' $ (fmap $ \x -> set self [attr := x]) <$> e+sink1 self (attr :==> b) = do+ x <- valueBLater b+ liftIOLater $ set self [attr :=> x]+ e <- changes b+ reactimate' $ (fmap $ \x -> set self [attr :=> x]) <$> e+sink1 self (attr :~~ b) = do+ x <- valueBLater b+ liftIOLater $ set self [attr :~ x]+ e <- changes b+ reactimate' $ (fmap $ \x -> set self [attr :~ x]) <$> e+sink1 self (attr :~~> b) = do+ x <- valueBLater b+ liftIOLater $ set self [attr :~> x]+ e <- changes b+ reactimate' $ (fmap $ \x -> set self [attr :~> x]) <$> e+sink1 self (attr ::== b) = do+ x <- valueBLater b+ liftIOLater $ set self [attr ::= x]+ e <- changes b+ reactimate' $ (fmap $ \x -> set self [attr ::= x]) <$> e+sink1 self (attr ::~~ b) = do+ x <- valueBLater b+ liftIOLater $ set self [attr ::~ x]+ e <- changes b+ reactimate' $ (fmap $ \x -> set self [attr ::~ x]) <$> e++-- "Animate" an attribute with a 'Reactive.Banana.Behavior'.+--+-- @+-- clickedE <- signalE0 button #clicked+-- clickedCount <- accumB (0 :: Int) ((+ 1) <$ clickedE)+-- sink myLabel [#label :== (T.pack . show) <$> clickedCount]+-- @+sink :: GObject self => self -> [AttrOpBehavior self AttrSet] -> MomentIO ()+sink self attrBs = mapM_ (sink1 self) attrBs
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"