diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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/reactive-banana-gi-gtk.cabal b/reactive-banana-gi-gtk.cabal new file mode 100644 --- /dev/null +++ b/reactive-banana-gi-gtk.cabal @@ -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 diff --git a/src/Reactive/Banana/GI/Gtk.hs b/src/Reactive/Banana/GI/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/GI/Gtk.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"