diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,116 @@ # reflex-gi-gtk + +This package provides the necessary plumbing to write reactive GUI +applications using GTK3+ (based on +[gi-gtk](https://hackage.haskell.org/package/gi-gtk/)) and +[reflex](https://hackage.haskell.org/package/reflex/). + +While this packes should make working with gi-gtk and reflex together +much easier than using them together without any kind of glue code, it +doesn't provide a lot of abstraction on top of either GTK or +reflex. People familiar with both gi-gtk and reflex separately should +have no trouble using reflex-gi-gtk successfully to build awesome +applications. + +## Installation + +The package can be compiled with [stack](https://haskellstack.org/) +using the shipped `stack.yaml` as follows: + +```Shell +$ stack install +``` + +The build process has mostly been tested using stack, but it should +also work using [cabal-install](https://www.haskell.org/cabal/) or +other standard `Cabal`-based package managers. + +## Quick start + +To start writing your reactive GUI application using reflex-gi-gtk, you will farst want to start the reactive part of your application using `runReflexGtk`, something like this: + +```Haskell +{-# LANGUAGE OverloadedStrings, OverloadedLabels, FlexibleContexts #-} + +import Control.Applicative (liftA2) +import GI.Gtk hiding (main) +import Reflex.GI.Gtk +import System.Environment +import System.Exit + +main :: IO () +main = do + argv <- (:) <$> getProgName <*> getArgs + Just gtkApplication <- applicationNew (Just "org.example.MyAwesomeApp") [] + rc <- runReflexGtk gtkApplication (Just argv) $ myReactiveCode gtkApplication + case rc of + 0 -> exitSuccess + n -> exitWith $ ExitFailure $ fromIntegral n +``` + +Inside the call to `runReflexGtk` you can assume that GTK has been +initialized and start creating GTK widgets: + +```Haskell +myReactiveCode :: (MonadReflexGtk t m) => Application -> m () +myReactiveCode gtkApplication = do + window <- runGtk $ applicationWindowNew gtkApplication + box <- runGtk $ boxNew OrientationVertical 0 + containerAdd window box + input1 <- runGtk entryNew + input2 <- runGtk entryNew + output <- runGtk $ labelNew Nothing + runGtk $ boxPackStart box input1 False False 0 + runGtk $ boxPackStart box input2 False False 0 + runGtk $ boxPackStart box output False False 0 +``` + +Note that we use `runGtk` to execute GTK functions instead of relying +on `liftIO`. This is because GTK functions are required to be run with +the correct thread local context. reflex-gi-gtk internally uses +multiple threads in a way that makes it hard to predict in which +thread a given piece of code will run. `runGtk` will ensure that the +lifted `IO` action is always run in the appropriate threading context +for GTK functions. + +You can also start obtaining reactive inputs from widget signals: + +```Haskell + text1 <- dynamicOnSignal "" input1 #changed $ \fire -> labelGetText input1 >>= fire + text2 <- dynamicOnAttribute input2 #text +``` + +This creates to `Dynamic`s containing texts. `text1` is constructed +based on the `#changed` event of the first input `Entry` while `text2` +is bound to the attribute `#text` of `input2`, but overall the effect +will be the same. Both `text1` and `text2` will always contain the +text entered into their respective input `Entry`. + +Once we have obtained reactive inputs, we can of course manipulate +them just as any other reactive values: + +```Haskell + let combinedText = liftA2 (<>) text1 text2 +``` + +In the end, we can also render dynamic values to attributes of GTK +widgets: + +```Haskell + sink output [#label :== combinedText] +``` + +Don't forget to call `widgetShowAll` on your window at an appropriate +time: + +```Haskell + _ <- gtkApplication `on` #activate $ widgetShowAll window + pure () +``` + +When you compile and run your program above, you should see your two +input boxes and the appropriate, dynamically updated output label. + +This is of course a very basic example. For more information you can +look at a more elaborate example in the `example` directory or at the +haddock documentation on hackage. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# 0.2.0.0 + +* Initial release diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -20,7 +20,7 @@ , switch ) import Reflex.GI.Gtk ( ReactiveAttrOp((:==)) - , MonadGtk + , MonadReflexGtk , runGtk , runReflexGtk , eventOnSignal @@ -37,7 +37,7 @@ , getProgName ) -stringInput :: (MonadGtk t m) +stringInput :: (MonadReflexGtk t m) => m (Gtk.Widget, Dynamic t T.Text, Event t ()) stringInput = do ( input @@ -50,6 +50,7 @@ fromIntegral $ fromEnum Gtk.IconSizeButton #packStart box input True True 0 #packStart box deleteButton False False 0 + #showAll box inputW <- Gtk.toWidget box pure (input, deleteButton, inputW) newTextE <- eventOnSignal input #changed (Gtk.get input #text >>=) @@ -104,6 +105,7 @@ let textB = join textBB label <- runGtk $ Gtk.labelNew Nothing sink label [#label :== textB] + #show label pure label sinkBoxUniform outputBox outputWidgets True True 10 Gtk.PackTypeStart diff --git a/reflex-gi-gtk.cabal b/reflex-gi-gtk.cabal --- a/reflex-gi-gtk.cabal +++ b/reflex-gi-gtk.cabal @@ -1,7 +1,10 @@ name: reflex-gi-gtk -version: 0.1.0.0 -synopsis: Helper functions to use Reflex with gi-gtk --- description: +version: 0.2.0.0 +synopsis: Helper functions to use reflex with gi-gtk +description: + This package provides a a reflex host and helper + functions to create reactive GUI applications + using gi-gtk and reflex. homepage: https://gitlab.com/Kritzefitz/reflex-gi-gtk#readme license: MPL-2.0 license-file: LICENSE @@ -11,7 +14,11 @@ category: FRP build-type: Simple extra-source-files: README.md -cabal-version: >=1.10 + , changelog.md + , stack.yaml + , stack.yaml.lock +stability: experimental +cabal-version: 2.0 library hs-source-dirs: src @@ -20,43 +27,48 @@ , Reflex.GI.Gtk.Host , Reflex.GI.Gtk.Input , Reflex.GI.Gtk.Output - , Reflex.GI.Gtk.Run.Class - , Reflex.GI.Gtk.Run.Base + , Reflex.GI.Gtk.Run + , Reflex.GI.Gtk.Widget + , Reflex.GI.Gtk.Widget.Bin , Reflex.GI.Gtk.Widget.Box - other-modules: Reflex.GI.Gtk.Widget.Ord - build-depends: async >= 2.2.2 && < 2.3 - , base >= 4.7 && < 5 - , containers >= 0.6.2 && < 0.7 - , dependent-sum >= 0.7.1 && < 0.8 - , exception-transformers == 0.4.* - , gi-gdk == 3.* - , gi-glib == 2.* - , gi-gtk == 3.* - , haskell-gi-base >= 0.24 && < 1 - , mtl >= 2.2.2 && < 2.3 - , primitive == 0.7.* - , ref-tf == 0.4.* - , reflex == 0.8.* - , semialign == 1.1.* - , stm == 2.5.* - , text >= 1.2.4 && < 1.3 - , these >= 1.1.1 && < 1.2 + , Reflex.GI.Gtk.Widget.Utils + other-modules: Reflex.GI.Gtk.Run.Base + , Reflex.GI.Gtk.Run.Class + , Reflex.GI.Gtk.Widget.Ord + build-depends: async ^>= 2.2.2 + , base ^>= 4.13 + , containers ^>= 0.6.2 + , dependent-sum ^>= 0.7.1 + , exception-transformers ^>= 0.4 + , gi-gdk ^>= 3.0 + , gi-glib ^>= 2.0 + , gi-gtk ^>= 3.0 + , haskell-gi-base ^>= 0.24 + , mtl ^>= 2.2.2 + , primitive ^>= 0.7 + , ref-tf ^>= 0.4 + , reflex ^>= 0.8 + , semialign ^>= 1.1 + , stm ^>= 2.5 + , text ^>= 1.2.4 + , these ^>= 1.1.1 + , witherable ^>= 0.3.5 default-language: Haskell2010 -executable reflex-test +executable reflex-gi-gtk-example hs-source-dirs: example main-is: Main.hs default-language: Haskell2010 build-depends: reflex-gi-gtk - , base >= 4.7 && < 5 - , containers >= 0.6.2 && < 0.7 - , dependent-sum >= 0.7.1 && < 0.8 - , gi-gtk == 3.* - , haskell-gi-base >= 0.24.5 && < 0.25 - , mtl >= 2.2.2 && < 2.3 - , patch == 0.0.* - , reflex == 0.8.* - , text >= 1.2.4 && < 1.3 + , base ^>= 4.13 + , containers ^>= 0.6.2 + , dependent-sum ^>= 0.7.1 + , gi-gtk ^>= 3.0 + , haskell-gi-base ^>= 0.24.5 + , mtl ^>= 2.2.2 + , patch ^>= 0.0 + , reflex ^>= 0.8 + , text ^>= 1.2.4 source-repository head type: git diff --git a/src/Reflex/GI/Gtk.hs b/src/Reflex/GI/Gtk.hs --- a/src/Reflex/GI/Gtk.hs +++ b/src/Reflex/GI/Gtk.hs @@ -5,30 +5,71 @@ {-# LANGUAGE DataKinds, GADTs, AllowAmbiguousTypes, RankNTypes #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, ConstraintKinds #-} +{-| +Description : Host and helpers for running reactive GTK interfaces with Reflex FRP +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides the most important functions to create reactive +interfaces using reflex and gi-gtk. + +'runReflexGtk' provides a reflex host, i.e. the top level entry point +to start constructing your reactive network. It relies on the User +providing a 'GI.Gtk.Application' to run. Running a GTK application +using the older 'GI.Gtk.init' and 'GI.Gtk.main' is currently not +supported. + +__Warning__: While 'runReflexGtk' provides access to +'Control.Monad.IO.Class.MonadIO' you should be careful not to execute +GTK-related functions using 'Control.Monad.IO.Class.liftIO'. GTK +functions expect to be called from the same OS thread that GTK was +initialized in. 'runReflexGtk' internally starts mutliple threads and +any code you write might not be run in the correct thread to execute +GTK functions. To make sure that your GTK function calls are performed +in the correct thread, use 'runGtk' which has the same type as +'Control.Monad.IO.Class.liftIO' and always makes sure that the lifted +IO action is run in the correct context to properly call GTK +functions. + +Reactive inputs can be obtained with the help of 'eventOnSignal0' and +similar helpers defined in "Reflex.GI.Gtk.Input". Reactive values can +be rendered as properties of widgets using 'sink'. The submodules of +"Reflex.GI.Gtk.Widget" also provide specific helpers for specific +widgets, such as 'sinkBox' or 'sinkBin' to render dynamic widgets into +'GI.Gtk.Box'es or 'GI.Gtk.Bin's respectively. +-} module Reflex.GI.Gtk ( -- * Running runReflexGtk - , MonadGtk + , ReflexGtk + , MonadReflexGtk -- * Executing IO in GTK context - , MonadRunGtk , runGtk , runGtk_ , runGtkPromise -- * Obtaining input from GTK sources , module Reflex.GI.Gtk.Input -- * Outputting reactive values to GTK widgets - , module Reflex.GI.Gtk.Output + , MonadGtkSink + , sink + , ReactiveAttrOp(..) -- * Helpers for specific widgets - , module Reflex.GI.Gtk.Widget.Box + , module Reflex.GI.Gtk.Widget ) where -import Reflex.GI.Gtk.Class (MonadGtk) -import Reflex.GI.Gtk.Host (runReflexGtk) +import Reflex.GI.Gtk.Class (MonadReflexGtk) +import Reflex.GI.Gtk.Host ( ReflexGtk + , runReflexGtk + ) import Reflex.GI.Gtk.Input -import Reflex.GI.Gtk.Output -import Reflex.GI.Gtk.Run.Class ( MonadRunGtk - , runGtk +import Reflex.GI.Gtk.Output ( MonadGtkSink + , ReactiveAttrOp(..) + , sink + ) +import Reflex.GI.Gtk.Run.Class ( runGtk , runGtk_ , runGtkPromise ) -import Reflex.GI.Gtk.Widget.Box +import Reflex.GI.Gtk.Widget diff --git a/src/Reflex/GI/Gtk/Class.hs b/src/Reflex/GI/Gtk/Class.hs --- a/src/Reflex/GI/Gtk/Class.hs +++ b/src/Reflex/GI/Gtk/Class.hs @@ -4,7 +4,14 @@ {-# LANGUAGE ConstraintKinds, FlexibleContexts #-} -module Reflex.GI.Gtk.Class (MonadGtk) where +{-| +Description : Interface class for reactive GTK +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental +-} +module Reflex.GI.Gtk.Class (MonadReflexGtk) where import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) @@ -17,21 +24,25 @@ , TriggerEvent ) import Reflex.Host.Class (ReflexHost) +import Reflex.GI.Gtk.Input (MonadGtkSource) import Reflex.GI.Gtk.Run.Class (MonadRunGtk) --- | A set of classes available in reactive code working with GTK. -type MonadGtk t m = ( MonadIO m - , MonadFix m - , MonadRunGtk m - , ReflexHost t - , MonadHold t m - , NotReady t m - , TriggerEvent t m - , PostBuild t m - , Adjustable t m - , PerformEvent t m - , MonadIO (Performable m) - , MonadRunGtk (Performable m) - , MonadFix (Performable m) - , MonadHold t (Performable m) - ) +-- | This class declares the interface provided for use in monadic +-- code for constructing reactive networks. The most notable +-- implementation is 'Reflex.GI.Gtk.Host.ReflexGtk'. +type MonadReflexGtk t m = ( MonadIO m + , MonadFix m + , MonadRunGtk m + , ReflexHost t + , MonadHold t m + , MonadGtkSource t m + , NotReady t m + , TriggerEvent t m + , PostBuild t m + , Adjustable t m + , PerformEvent t m + , MonadIO (Performable m) + , MonadRunGtk (Performable m) + , MonadFix (Performable m) + , MonadHold t (Performable m) + ) diff --git a/src/Reflex/GI/Gtk/Host.hs b/src/Reflex/GI/Gtk/Host.hs --- a/src/Reflex/GI/Gtk/Host.hs +++ b/src/Reflex/GI/Gtk/Host.hs @@ -2,80 +2,240 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at https://mozilla.org/MPL/2.0/. -{-# LANGUAGE RankNTypes, FlexibleContexts, PatternSynonyms, OverloadedLabels, RecursiveDo #-} +{-# LANGUAGE RankNTypes, FlexibleContexts, OverloadedLabels, RecursiveDo #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, GADTs, ScopedTypeVariables #-} +{-| +Description : Execute monadic actions with access to reactive operators on GTK +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides the top-level entry-point for running reactive +GTK applications, namely 'runReflexGtk'. +-} module Reflex.GI.Gtk.Host - ( MonadGtk - , runReflexGtk + ( runReflexGtk + , ReflexGtk + , ReflexGtkT ) where -import Control.Concurrent (myThreadId) +import Control.Concurrent ( isCurrentThreadBound + , runInBoundThread + ) import Control.Concurrent.Async ( async , waitCatchSTM ) import Control.Concurrent.Chan ( newChan , readChan ) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Ref (readRef) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class ( MonadIO + , liftIO + ) +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.Ref ( MonadRef + , Ref + , readRef + ) +import Control.Monad.Trans (lift) import Data.Dependent.Sum ( DSum((:=>)) , (==>) ) import Data.Function (fix) +import Data.GI.Base.Signals (disconnectSignalHandler) import Data.Int (Int32) import Data.Maybe (catMaybes) import Data.Void (absurd) +import GI.GLib ( Thread + , threadSelf + ) import GI.Gtk ( Application , on ) -import Reflex ( FireCommand(FireCommand) +import Reflex ( Adjustable( runWithReplace + , traverseIntMapWithKeyWithAdjust + , traverseDMapWithKeyWithAdjust + , traverseDMapWithKeyWithAdjustWithMove + ) + , FireCommand(FireCommand) + , MonadHold + , MonadSample + , NotReady + , PerformEvent + , PerformEventT + , PostBuild + , PostBuildT + , SpiderHost + , SpiderTimeline + , TriggerEvent + , TriggerEventT , TriggerInvocation(TriggerInvocation) , hostPerformEventT + , newEventWithLazyTriggerWithOnComplete , runPostBuildT , runSpiderHostForTimeline , runTriggerEventT , unEventTriggerRef , withSpiderTimeline ) -import Reflex.GI.Gtk.Class (MonadGtk) -import Reflex.GI.Gtk.Run.Base (runGtkT) -import Reflex.Host.Class (newEventWithTriggerRef) +import Reflex.GI.Gtk.Input ( FireAsync( FireAsync + , FireSync + ) + , MonadGtkSource(eventFromSignalWith) + ) +import Reflex.GI.Gtk.Run ( MonadRunGtk( runGtk + , runGtk_ + , runGtkPromise + ) + ) +import Reflex.GI.Gtk.Run.Base ( RunGtkT + , runGtkT + , askRunGtk + , askRunGtk_ + , askMakeSynchronousFire + ) +import Reflex.Host.Class ( HostFrame + , ReflexHost + , newEventWithTriggerRef + ) +import Reflex.Spider.Internal (HasSpiderTimeline) +-- | A monad providing an implementation for +-- 'Reflex.GI.Gtk.Class.MonadReflexGtk' given a suitable reflex host +-- (such as 'SpiderHost') as a base monad. +-- +-- Your probably want to look at 'ReflexGtk', as it is the only +-- specialization of this type that can be executed using +-- 'runReflexGtk'. +newtype ReflexGtkT (t :: *) (m :: k) a = ReflexGtkT + { unReflexGtkT :: PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a + } + deriving (Functor, Applicative, Monad, MonadFix) + +-- | This is the monad that reactive GTK code is run in. Notably this +-- type implements 'Reflex.GI.Gtk.Class.MonadReflexGtk' when run with +-- 'runReflexGtk'. +type ReflexGtk x = ReflexGtkT (SpiderTimeline x) (SpiderHost x) + +deriving instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (ReflexGtkT t m) +deriving instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (ReflexGtkT t m) +deriving instance (ReflexHost t, NotReady t (PerformEventT t m)) => NotReady t (ReflexGtkT t m) +deriving instance ( ReflexHost t + , MonadRef (HostFrame t) + , Ref (HostFrame t) ~ Ref IO + ) => TriggerEvent t (ReflexGtkT t m) +deriving instance (ReflexHost t) => PostBuild t (ReflexGtkT t m) +deriving instance (ReflexHost t) => MonadSample t (ReflexGtkT t m) +deriving instance (ReflexHost t, MonadHold t m) => MonadHold t (ReflexGtkT t m) +deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (ReflexGtkT t m) + +instance ( ReflexHost t + , PrimMonad (HostFrame t) + , MonadHold t m + , Ref m ~ Ref IO + ) => Adjustable t (ReflexGtkT t m) where + runWithReplace initial replace = + ReflexGtkT $ runWithReplace (unReflexGtkT initial) (unReflexGtkT <$> replace) + traverseDMapWithKeyWithAdjust f initial = + ReflexGtkT . traverseDMapWithKeyWithAdjust (\k v -> unReflexGtkT $ f k v) initial + traverseDMapWithKeyWithAdjustWithMove f initial = + ReflexGtkT . traverseDMapWithKeyWithAdjustWithMove (\k v -> unReflexGtkT $ f k v) initial + traverseIntMapWithKeyWithAdjust f initial = + ReflexGtkT . traverseIntMapWithKeyWithAdjust (\k v -> unReflexGtkT $ f k v) initial + +instance (ReflexHost t, MonadIO (HostFrame t)) => MonadRunGtk (ReflexGtkT t m) where + runGtk = ReflexGtkT . runGtk + runGtk_ = ReflexGtkT . runGtk_ + runGtkPromise = fmap ReflexGtkT . ReflexGtkT . runGtkPromise + +-- Lift an operation from 'RunGtkT' to 'ReflexGtkT'. +liftFromRunGtkT :: (ReflexHost t) => RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a +liftFromRunGtkT = ReflexGtkT . lift . lift + +-- | Returns a function to fire synchronous or asynchronous event as +-- specified by the argument. +askMakeFireWith :: (ReflexHost t) + => FireAsync + -> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ()) +askMakeFireWith FireAsync = pure $ \f x -> f x $ pure () +askMakeFireWith FireSync = liftFromRunGtkT askMakeSynchronousFire + +instance ( ReflexHost t + , MonadIO (HostFrame t) + , MonadRef (HostFrame t) + , Ref (HostFrame t) ~ Ref IO + ) => MonadGtkSource t (ReflexGtkT t m) where + eventFromSignalWith register sync object signal f = do + runGtk' <- liftFromRunGtkT askRunGtk + runGtk_' <- liftFromRunGtkT askRunGtk_ + makeSynchronousFire <- askMakeFireWith sync + newEventWithLazyTriggerWithOnComplete $ \fire -> + runGtk_' . disconnectSignalHandler object + <$> runGtk' ( object `register` signal $ + f $ \x -> makeSynchronousFire fire x + ) + +-- | The top-level entry point for reactive GTK applications. +-- +-- You have to provide an existing 'Application' which will run the +-- GTK application. 'GI.Gtk.applicationRun' should not be called on +-- the Application manually, as this function expects to start the +-- mainloop by itself. However, apart from that, you may use the +-- 'Application' as you wish, for example by setting appropriate +-- 'GI.Gtk.ApplicationFlags', binding to its signals, assigning +-- 'GI.Gtk.Window's to it or changing its attributes. runReflexGtk :: Application + -- ^ The application to run the GTK mainloop on. -> Maybe [String] - -> (forall t m. (MonadGtk t m) => m ()) + -- ^ The arguments to provide to 'GI.Gtk.applicationRun' + -> (forall x. (HasSpiderTimeline x) => ReflexGtk x ()) + -- ^ The user-provided monadic action to set up your + -- reactive network. -> IO Int32 -runReflexGtk app argv a = do + -- ^ The exit code as returned by 'GI.Gtk.applicationRun' +runReflexGtk app argv a = runInBoundThread $ do _ <- app `on` #startup $ withSpiderTimeline $ \tl -> flip runSpiderHostForTimeline tl $ do - eventChan <- liftIO newChan - rec - let waitForEventThreadException = - either id absurd <$> waitCatchSTM eventThread + eventChan <- liftIO newChan + rec + let waitForEventThreadException = + either id absurd <$> waitCatchSTM eventThread - (postBuildE, postBuildTriggerRef) <- newEventWithTriggerRef - ((), FireCommand fireCommand) <- - hostPerformEventT $ - liftIO myThreadId - >>= runGtkT ( - runTriggerEventT ( runPostBuildT a postBuildE - ) eventChan - ) waitForEventThreadException + (postBuildE, postBuildTriggerRef) <- newEventWithTriggerRef + ((), FireCommand fireCommand) <- + hostPerformEventT $ + liftIO getCurrentAsGtkThread + >>= runGtkT ( + runTriggerEventT ( runPostBuildT (unReflexGtkT a) postBuildE + ) eventChan + ) waitForEventThreadException - readRef postBuildTriggerRef - >>= mapM_ (\trigger -> fireCommand [trigger ==> ()] $ pure ()) + readRef postBuildTriggerRef + >>= mapM_ (\trigger -> fireCommand [trigger ==> ()] $ pure ()) - eventThread <- liftIO $ async $ flip runSpiderHostForTimeline tl $ fix $ \loop -> do - invocations <- liftIO $ readChan eventChan - triggers <- - catMaybes <$> - traverse (\(triggerRef :=> TriggerInvocation x _) -> - fmap (==> x) <$> readRef (unEventTriggerRef triggerRef) - ) invocations - _ <- fireCommand triggers $ pure () - liftIO $ mapM_ (\(_ :=> (TriggerInvocation _ done)) -> done) invocations - loop - pure () + eventThread <- liftIO $ async $ flip runSpiderHostForTimeline tl $ fix $ \loop -> do + invocations <- liftIO $ readChan eventChan + triggers <- + catMaybes <$> + traverse (\(triggerRef :=> TriggerInvocation x _) -> + fmap (==> x) <$> readRef (unEventTriggerRef triggerRef) + ) invocations + _ <- fireCommand triggers $ pure () + liftIO $ mapM_ (\(_ :=> (TriggerInvocation _ done)) -> done) invocations + loop + pure () #run app argv + +-- | Like myThreadId, but returns a GLib 'Thread' combined with the +-- assertion that the current thread is bound. +getCurrentAsGtkThread :: IO Thread +getCurrentAsGtkThread = do + iAmBound <- isCurrentThreadBound + if iAmBound + then threadSelf + else error "getCurrentAsGtkThread: Can't be GTK thread, because I am not bound" diff --git a/src/Reflex/GI/Gtk/Input.hs b/src/Reflex/GI/Gtk/Input.hs --- a/src/Reflex/GI/Gtk/Input.hs +++ b/src/Reflex/GI/Gtk/Input.hs @@ -2,43 +2,58 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at https://mozilla.org/MPL/2.0/. -{-# LANGUAGE ConstraintKinds, GADTs, FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds, GADTs, FlexibleContexts, MultiParamTypeClasses #-} +{-| +Description : Obtain reactive inputs from GLib signals +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides helpers for constructing input 'Event's, +'Behavior's, and 'Dynamic's from GLib signals and attributes. +-} module Reflex.GI.Gtk.Input - ( MonadGtkSource - -- * Obtaining input from GI signals + ( -- * Obtaining input from GI signals -- ** as 'Event's + MonadGtkSource(eventFromSignalWith) , eventOnSignal - , eventAfterSignal , eventOnSignal0 - , eventAfterSignal0 + , eventFromSignalWith0 , eventOnSignal1 - , eventAfterSignal1 + , eventFromSignalWith1 , eventOnSignal0R - , eventAfterSignal0R + , eventFromSignalWith0R , eventOnSignal1R - , eventAfterSignal1R + , eventFromSignalWith1R -- ** as 'Behavior's , behaviorOnSignal - , behaviorAfterSignal + , behaviorFromSignalWith , behaviorOnSignal1 - , behaviorAfterSignal1 + , behaviorFromSignalWith1 , behaviorOnSignal1R - , behaviorAfterSignal1R + , behaviorFromSignalWith1R -- ** as 'Dynamic's , dynamicOnSignal - , dynamicAfterSignal + , dynamicFromSignalWith , dynamicOnSignal1 - , dynamicAfterSignal1 + , dynamicFromSignalWith1 , dynamicOnSignal1R - , dynamicAfterSignal1R + , dynamicFromSignalWith1R -- * Obtaining input from GI attributes , eventOnAttribute - , eventAfterAttribute + , eventFromAttributeWith , behaviorOnAttribute - , behaviorAfterAttribute + , behaviorFromAttributeWith , dynamicOnAttribute - , dynamicAfterAttribute + , dynamicFromAttributeWith + -- * Synchronous vs asynchronous event triggers + -- + -- $syncvsasync + , FireAsync(..) + -- * Miscellanous + , Registerer ) where import Data.GI.Base (GObject) @@ -47,12 +62,11 @@ , AttrLabelProxy , get ) -import Data.GI.Base.Signals ( HaskellCallbackType +import Data.GI.Base.Signals ( GObjectNotifySignalInfo + , HaskellCallbackType , SignalHandlerId , SignalInfo , SignalProxy(PropertyNotify) - , after - , disconnectSignalHandler , on ) import GHC.TypeLits (KnownSymbol) @@ -63,233 +77,495 @@ , TriggerEvent , hold , holdDyn - , newEventWithLazyTriggerWithOnComplete ) import Reflex.GI.Gtk.Run.Class ( MonadRunGtk - , askMakeSynchronousFire - , askRunGtk - , askRunGtk_ , runGtk ) -type MonadGtkSource t m = ( MonadRunGtk m - , TriggerEvent t m - ) +-- | This class provides the creation of reactive inputs from GLib +-- signals. +class ( MonadRunGtk m + , TriggerEvent t m + ) => MonadGtkSource t m where + -- | Turns a GLib signal into a reactive 'Event'. + eventFromSignalWith :: ( GObject object + , SignalInfo info + ) + => Registerer object info -- ^ A function to + -- register a handler for a GLib + -- signal. Usually 'on' or 'GI.Gtk.after'. + -> FireAsync -- ^ Whether to fire the event + -- synchronously or asynchronously. See + -- /Synchronous vs asynchronous event triggers/ + -- for a more in-depth explanation. + -> object -- ^ The object emitting the signal + -> SignalProxy object info -- ^ The signal to bind to + -> ((a -> IO ()) -> HaskellCallbackType info) + -- ^ A helper function that is called in the + -- handler of the signal. It receives an + -- operation @fire@ that emits the + -- constructed event with the passed + -- value. Is also responsible for handling + -- the arguments provided by the signal and + -- returning an appropriate value expected by + -- the signal. + -> m (Event t a) -- ^ An 'Event' that is emitted + -- whenever the GLib signal occurs — or + -- rather whenever the passed helper function + -- calls @fire@. -eventFromSignalWith :: ( MonadGtkSource t m - , GObject object - , SignalInfo info - ) - => ( object -> SignalProxy object info -> - HaskellCallbackType info -> IO SignalHandlerId - ) - -> object - -> SignalProxy object info - -> ((a -> IO ()) -> HaskellCallbackType info) - -> m (Event t a) -eventFromSignalWith register object signal f = do - runGtk' <- askRunGtk - runGtk_' <- askRunGtk_ - makeSynchronousFire <- askMakeSynchronousFire - newEventWithLazyTriggerWithOnComplete $ \fire -> - runGtk_' . disconnectSignalHandler object - <$> runGtk' ( object `register` signal $ - f $ \x -> makeSynchronousFire fire x - ) +-- | A shorthand for the types of 'on' and 'GI.Gtk.after' as required +-- by the helpers in this module. +type Registerer object info = + object -> SignalProxy object info -> HaskellCallbackType info -> IO SignalHandlerId -eventOnSignal, eventAfterSignal :: ( MonadGtkSource t m - , GObject object - , SignalInfo info - ) - => object - -> SignalProxy object info - -> ((a -> IO ()) -> HaskellCallbackType info) - -> m (Event t a) -eventOnSignal = eventFromSignalWith on -eventAfterSignal = eventFromSignalWith after +-- $syncvsasync +-- +-- When a signal is emitted by GTK the main loop of GTK is not able to +-- run until the handler(s) for the signal have returned. During this +-- time, the GUI becomes unresponsive. This prevents the user from +-- interacting with the GUI and may cause certain operating systems to +-- display a warning to the user if the GUI stays unresponsive for too +-- long. +-- +-- This may or may or may not be desirable depending on the signal +-- being handled and the actions taken in response to the signal. So +-- depending on the circumstances it may be appropriate to carry out +-- all actions triggered by a signal synchronously in the signal +-- handler before it returns, while for other actions it may be more +-- appropriate to trigger the effects of the action to be applied +-- asynchronously (in another thread) and return from the signal +-- handler as soon as possible. +-- +-- Usually actions that can be carried out quickly and are expected to +-- show an effect immediately by the user should be handled +-- synchronously, because this provides a relatively intuitive +-- indication to the user that work is still being done in the rare +-- case that the action is not as immediate as intended. This +-- indication usually comes in the form of the GUI being marked as +-- unresponsive and for example the pressed button still displaying +-- the pressed animation. +-- +-- Actions that trigger long running processes on the other hand +-- should usually be handled asynchronously, so the user is not left +-- with an unresponsive GUI for an extended period of time. However, +-- this is usually also more elaborate to implement, because the user +-- should still have an indicator that there is still progress being +-- made on the requested action. +-- +-- The helpers defined in this module can be parametrized to bind +-- either synchronous signal handlers that wait for the event +-- propagation to fully complete or asynchronous handlers that just +-- mark the signal propagation to be handled later and return as soon +-- as possible. The shorthand versions @*OnSignal*@ bind synchronous +-- handlers, while the more general variants @*FromSignalWith*@ +-- support both synchronous and asynchronous handlers. -eventOnSignal0, eventAfterSignal0 :: ( MonadGtkSource t m - , HaskellCallbackType info ~ IO () +-- | A sum type to select between synchronous and asynchronous event +-- propagation. +data FireAsync = FireAsync -- ^ Specify asynchronous event propagation + | FireSync -- ^ Specify synchronous event propagation + deriving (Show, Read, Eq) + +-- | 'eventFromSignalWith' pre-applied to 'on' and 'FireSync' +eventOnSignal :: ( MonadGtkSource t m + , GObject object + , SignalInfo info + ) + => object + -> SignalProxy object info + -> ((a -> IO ()) -> HaskellCallbackType info) + -> m (Event t a) +eventOnSignal = eventFromSignalWith on FireSync + +-- | A specialization of 'eventFromSignalWith' for signal handlers +-- without arguments or return types. +eventFromSignalWith0 :: ( MonadGtkSource t m + , GObject object + , SignalInfo info + , HaskellCallbackType info ~ IO () + ) + => Registerer object info + -> FireAsync + -> object + -> SignalProxy object info + -> m (Event t ()) +eventFromSignalWith0 register sync object signal = + eventFromSignalWith register sync object signal ($ ()) + +-- | 'eventFromSignalWith0' pre-applied to 'on' and 'FireSync' +eventOnSignal0 :: ( MonadGtkSource t m + , HaskellCallbackType info ~ IO () + , GObject object + , SignalInfo info + ) + => object + -> SignalProxy object info + -> m (Event t ()) +eventOnSignal0 = eventFromSignalWith0 on FireSync + +-- | A specialization of 'eventFromSignalWith' for signal handlers +-- with exactly one argument and no return type. The argument is used +-- as a value for the emitted 'Event'. +eventFromSignalWith1 :: ( MonadGtkSource t m + , HaskellCallbackType info ~ (a -> IO ()) + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> object + -> SignalProxy object info + -> m (Event t a) +eventFromSignalWith1 register sync object signal = + eventFromSignalWith register sync object signal id + +-- | 'eventFromSignalWith1' pre-applied to 'on' and 'FireSync' +eventOnSignal1 :: ( MonadGtkSource t m + , HaskellCallbackType info ~ (a -> IO ()) + , GObject object + , SignalInfo info + ) + => object + -> SignalProxy object info + -> m (Event t a) +eventOnSignal1 = eventFromSignalWith1 on FireSync + +-- | A specialization of 'eventFromSignalWith' for signal handlers +-- with no arguments and an expected return type. The bound signal +-- handler will returns the supplied constant value. +eventFromSignalWith0R :: ( MonadGtkSource t m + , HaskellCallbackType info ~ IO b + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> object + -> SignalProxy object info + -> b + -> m (Event t ()) +eventFromSignalWith0R register sync obj signal x = + eventFromSignalWith register sync obj signal $ \fire -> x <$ fire () + +-- | 'eventFromSignalWith0R' pre-applied to 'on' and 'FireSync' +eventOnSignal0R :: ( MonadGtkSource t m + , HaskellCallbackType info ~ IO b + , GObject object + , SignalInfo info + ) + => object + -> SignalProxy object info + -> b + -> m (Event t ()) +eventOnSignal0R = eventFromSignalWith0R on FireSync + +-- | A specialized version of 'eventFromSignalWith' for signal +-- handlers with exactly one argument and an expected return type. The +-- bound signal handler will always return the supplied constant value +-- and the argument will be used as a value for the emitted event. +eventFromSignalWith1R :: ( MonadGtkSource t m + , HaskellCallbackType info ~ (a -> IO b) + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> object + -> SignalProxy object info + -> b + -> m (Event t a) +eventFromSignalWith1R register sync obj signal r = + eventFromSignalWith register sync obj signal $ \fire v -> r <$ fire v + +-- | 'eventFromSignalWith1R' pre-applied to 'on' and 'FireSync' +eventOnSignal1R :: ( MonadGtkSource t m + , HaskellCallbackType info ~ (a -> IO b) + , GObject object + , SignalInfo info + ) + => object + -> SignalProxy object info + -> b + -> m (Event t a) +eventOnSignal1R = eventFromSignalWith1R on FireSync + +-- | A shorthand to create an input event with 'eventFromSignalWith' and +-- 'hold' the resulting event using the provided initial value. +behaviorFromSignalWith :: ( MonadGtkSource t m + , MonadHold t m + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> a -- ^ The initial value + -> object + -> SignalProxy object info + -> ((a -> IO ()) -> HaskellCallbackType info) + -> m (Behavior t a) +behaviorFromSignalWith register sync initial object signal f = + eventFromSignalWith register sync object signal f >>= hold initial + +-- | 'behaviorFromSignalWith' pre-applied to 'on' and 'FireSync' +behaviorOnSignal :: ( MonadGtkSource t m + , MonadHold t m , GObject object , SignalInfo info ) - => object + => a + -> object -> SignalProxy object info - -> m (Event t ()) -eventOnSignal0 obj signal = eventOnSignal obj signal ($ ()) -eventAfterSignal0 obj signal = eventAfterSignal obj signal ($ ()) + -> ((a -> IO ()) -> HaskellCallbackType info) + -> m (Behavior t a) +behaviorOnSignal = behaviorFromSignalWith on FireSync -eventOnSignal1, eventAfterSignal1 :: ( MonadGtkSource t m - , HaskellCallbackType info ~ (a -> IO ()) - , GObject object - , SignalInfo info - ) - => object - -> SignalProxy object info - -> m (Event t a) -eventOnSignal1 obj signal = eventOnSignal obj signal id -eventAfterSignal1 obj signal = eventAfterSignal obj signal id +-- | 'behaviorFromSignalWith' but specialized like +-- 'eventFromSignalWith1' +behaviorFromSignalWith1 :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO ()) + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> a + -> object + -> SignalProxy object info + -> m (Behavior t a) +behaviorFromSignalWith1 register sync initial object signal = + eventFromSignalWith1 register sync object signal >>= hold initial -eventOnSignal0R, eventAfterSignal0R :: ( MonadGtkSource t m - , HaskellCallbackType info ~ IO b - , GObject object - , SignalInfo info - ) - => object - -> SignalProxy object info - -> b - -> m (Event t ()) -eventOnSignal0R obj signal x = eventOnSignal obj signal $ \fire -> x <$ fire () -eventAfterSignal0R obj signal x = eventAfterSignal obj signal $ \fire -> x <$ fire () +-- | 'behaviorFromSignalWith1' pre-applied to 'on' and 'FireSync' +behaviorOnSignal1 :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO ()) + , GObject object + , SignalInfo info + ) + => a + -> object + -> SignalProxy object info + -> m (Behavior t a) +behaviorOnSignal1 = behaviorFromSignalWith1 on FireSync -eventOnSignal1R, eventAfterSignal1R :: ( MonadGtkSource t m - , HaskellCallbackType info ~ (a -> IO b) - , GObject object - , SignalInfo info - ) - => object - -> SignalProxy object info - -> b - -> m (Event t a) -eventOnSignal1R obj signal r = eventOnSignal obj signal $ \fire v -> r <$ fire v -eventAfterSignal1R obj signal r = eventAfterSignal obj signal $ \fire v -> r <$ fire v +-- | 'behaviorFromSignalWith' but specialized like +-- 'eventFromSignalWith1R' +behaviorFromSignalWith1R :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO b) + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> a + -> object + -> SignalProxy object info + -> b + -> m (Behavior t a) +behaviorFromSignalWith1R register sync initial object signal result = + eventFromSignalWith1R register sync object signal result >>= hold initial -behaviorOnSignal, behaviorAfterSignal :: ( MonadGtkSource t m - , MonadHold t m - , GObject object - , SignalInfo info - ) - => a - -> object - -> SignalProxy object info - -> ((a -> IO ()) -> HaskellCallbackType info) - -> m (Behavior t a) -behaviorOnSignal initial object signal f = - eventOnSignal object signal f >>= hold initial -behaviorAfterSignal initial object signal f = - eventAfterSignal object signal f >>= hold initial +-- | 'behaviorFromSignalWith1R' pre-applied to 'on' and 'FireSync' +behaviorOnSignal1R :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO b) + , GObject object + , SignalInfo info + ) + => a + -> object + -> SignalProxy object info + -> b + -> m (Behavior t a) +behaviorOnSignal1R = behaviorFromSignalWith1R on FireSync -behaviorOnSignal1, behaviorAfterSignal1 :: ( MonadGtkSource t m - , MonadHold t m - , HaskellCallbackType info ~ (a -> IO ()) - , GObject object - , SignalInfo info - ) - => a - -> object - -> SignalProxy object info - -> m (Behavior t a) -behaviorOnSignal1 initial object signal = - eventOnSignal1 object signal >>= hold initial -behaviorAfterSignal1 initial object signal = - eventAfterSignal1 object signal >>= hold initial +-- | A shorthand to create an input event with 'eventFromSignalWith' and +-- 'holdDyn' the resulting event using the provided initial value. +dynamicFromSignalWith :: ( MonadGtkSource t m + , MonadHold t m + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> a + -> object + -> SignalProxy object info + -> ((a -> IO ()) -> HaskellCallbackType info) + -> m (Dynamic t a) +dynamicFromSignalWith register sync initial object signal f = + eventFromSignalWith register sync object signal f >>= holdDyn initial -behaviorOnSignal1R, behaviorAfterSignal1R :: ( MonadGtkSource t m - , MonadHold t m - , HaskellCallbackType info ~ (a -> IO b) - , GObject object - , SignalInfo info - ) - => a - -> object - -> SignalProxy object info - -> b - -> m (Behavior t a) -behaviorOnSignal1R initial object signal result = - eventOnSignal1R object signal result >>= hold initial -behaviorAfterSignal1R initial object signal result = - eventAfterSignal1R object signal result >>= hold initial +-- | 'dynamicFromSignalWith' pre-applied to 'on' and 'FireSync' +dynamicOnSignal :: ( MonadGtkSource t m + , MonadHold t m + , GObject object + , SignalInfo info + ) + => a + -> object + -> SignalProxy object info + -> ((a -> IO ()) -> HaskellCallbackType info) + -> m (Dynamic t a) +dynamicOnSignal = dynamicFromSignalWith on FireSync +-- | 'dynamicFromSignalWith' but specialized like +-- 'eventFromSignalWith1' +dynamicFromSignalWith1 :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO ()) + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> a + -> object + -> SignalProxy object info + -> m (Dynamic t a) +dynamicFromSignalWith1 register sync initial object signal = + eventFromSignalWith1 register sync object signal >>= holdDyn initial -dynamicOnSignal, dynamicAfterSignal :: ( MonadGtkSource t m - , MonadHold t m - , GObject object - , SignalInfo info - ) - => a - -> object - -> SignalProxy object info - -> ((a -> IO ()) -> HaskellCallbackType info) - -> m (Dynamic t a) -dynamicOnSignal initial object signal f = - eventOnSignal object signal f >>= holdDyn initial -dynamicAfterSignal initial object signal f = - eventAfterSignal object signal f >>= holdDyn initial +-- | 'dynamicFromSignalWith1' pre-applied to 'on' and 'FireSync' +dynamicOnSignal1 :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO ()) + , GObject object + , SignalInfo info + ) + => a + -> object + -> SignalProxy object info + -> m (Dynamic t a) +dynamicOnSignal1 = dynamicFromSignalWith1 on FireSync -dynamicOnSignal1, dynamicAfterSignal1 :: ( MonadGtkSource t m - , MonadHold t m - , HaskellCallbackType info ~ (a -> IO ()) - , GObject object - , SignalInfo info - ) - => a - -> object - -> SignalProxy object info - -> m (Dynamic t a) -dynamicOnSignal1 initial object signal = - eventOnSignal1 object signal >>= holdDyn initial -dynamicAfterSignal1 initial object signal = - eventAfterSignal1 object signal >>= holdDyn initial +-- | 'dynamicFromSignalWith' but specialized like +-- 'eventFromSignalWith1R' +dynamicFromSignalWith1R :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO b) + , GObject object + , SignalInfo info + ) + => Registerer object info + -> FireAsync + -> a + -> object + -> SignalProxy object info + -> b + -> m (Dynamic t a) +dynamicFromSignalWith1R register sync initial object signal result = + eventFromSignalWith1R register sync object signal result >>= holdDyn initial -dynamicOnSignal1R, dynamicAfterSignal1R :: ( MonadGtkSource t m - , MonadHold t m - , HaskellCallbackType info ~ (a -> IO b) - , GObject object - , SignalInfo info - ) - => a - -> object - -> SignalProxy object info - -> b - -> m (Dynamic t a) -dynamicOnSignal1R initial object signal result = - eventOnSignal1R object signal result >>= holdDyn initial -dynamicAfterSignal1R initial object signal result = - eventAfterSignal1R object signal result >>= holdDyn initial +-- | 'dynamicFromSignalWith1R' pre-applied to 'on' and 'FireSync' +dynamicOnSignal1R :: ( MonadGtkSource t m + , MonadHold t m + , HaskellCallbackType info ~ (a -> IO b) + , GObject object + , SignalInfo info + ) + => a + -> object + -> SignalProxy object info + -> b + -> m (Dynamic t a) +dynamicOnSignal1R = dynamicFromSignalWith1R on FireSync -eventOnAttribute, eventAfterAttribute :: ( MonadGtkSource t m - , AttrGetC info object attr value - , GObject object - , KnownSymbol (AttrLabel info) - ) - => object - -> AttrLabelProxy attr - -> m (Event t value) -eventOnAttribute object attr = - eventOnSignal object (PropertyNotify attr) $ \fire _ -> - get object attr >>= fire -eventAfterAttribute object attr = - eventAfterSignal object (PropertyNotify attr) $ \fire _ -> +-- | Construct an input 'Event' that fires whenever a given attribute +-- changes. +eventFromAttributeWith :: ( MonadGtkSource t m + , AttrGetC info object attr value + , GObject object + , KnownSymbol (AttrLabel info) + ) + => Registerer object GObjectNotifySignalInfo + -- ^ The function used to register the + -- signal handler, usually either 'on' or + -- 'GI.Gtk.after'. + -> FireAsync -- ^ synchronous or asynchronous + -- signal emission + -> object -- ^ The object the attribute belongs + -- to + -> AttrLabelProxy attr -- ^ The attribute to + -- watch + -> m (Event t value) -- ^ The signal that emits + -- new values of the attribute +eventFromAttributeWith register sync object attr = + eventFromSignalWith register sync object (PropertyNotify attr) $ \fire _ -> get object attr >>= fire -behaviorOnAttribute, behaviorAfterAttribute :: ( MonadGtkSource t m - , MonadHold t m - , AttrGetC info object attr value - , GObject object - , KnownSymbol (AttrLabel info) - ) - => object - -> AttrLabelProxy attr - -> m (Behavior t value) -behaviorOnAttribute object attr = do - initial <- runGtk $ get object attr - eventOnAttribute object attr >>= hold initial -behaviorAfterAttribute object attr = do - initial <- runGtk $ get object attr - eventAfterAttribute object attr >>= hold initial +-- | 'eventFromAttributeWith' pre-applied to 'on' and 'FireSync' +eventOnAttribute :: ( MonadGtkSource t m + , AttrGetC info object attr value + , GObject object + , KnownSymbol (AttrLabel info) + ) + => object + -> AttrLabelProxy attr + -> m (Event t value) +eventOnAttribute = eventFromAttributeWith on FireSync -dynamicOnAttribute, dynamicAfterAttribute :: ( MonadGtkSource t m - , MonadHold t m - , AttrGetC info object attr value - , GObject object - , KnownSymbol (AttrLabel info) - ) - => object - -> AttrLabelProxy attr - -> m (Dynamic t value) -dynamicOnAttribute object attr = do +-- | A shorthand to construct an input 'Event' using +-- 'eventFromAttributeWith' and 'hold' it with the current value of +-- the attribute as the initial value. +-- +-- This means that the constructed 'Behavior' always has the same +-- value as the attribute. +behaviorFromAttributeWith :: ( MonadGtkSource t m + , MonadHold t m + , AttrGetC info object attr value + , GObject object + , KnownSymbol (AttrLabel info) + ) + => Registerer object GObjectNotifySignalInfo + -> FireAsync + -> object + -> AttrLabelProxy attr + -> m (Behavior t value) +behaviorFromAttributeWith register sync object attr = do initial <- runGtk $ get object attr - eventOnAttribute object attr >>= holdDyn initial -dynamicAfterAttribute object attr = do + eventFromAttributeWith register sync object attr >>= hold initial + +-- | 'behaviorFromAttributeWith' pre-applied to 'on' and 'FireSync' +behaviorOnAttribute :: ( MonadGtkSource t m + , MonadHold t m + , AttrGetC info object attr value + , GObject object + , KnownSymbol (AttrLabel info) + ) + => object + -> AttrLabelProxy attr + -> m (Behavior t value) +behaviorOnAttribute = behaviorFromAttributeWith on FireSync + +-- | Like 'behaviorFromAttributeWith' but constructs a 'Dynamic' +-- instead of a 'Behavior' +dynamicFromAttributeWith :: ( MonadGtkSource t m + , MonadHold t m + , AttrGetC info object attr value + , GObject object + , KnownSymbol (AttrLabel info) + ) + => Registerer object GObjectNotifySignalInfo + -> FireAsync + -> object + -> AttrLabelProxy attr + -> m (Dynamic t value) +dynamicFromAttributeWith register sync object attr = do initial <- runGtk $ get object attr - eventAfterAttribute object attr >>= holdDyn initial + eventFromAttributeWith register sync object attr >>= holdDyn initial + +-- | 'dynamicFromAttributeWith' pre-applied to 'on' and 'FireSync' +dynamicOnAttribute :: ( MonadGtkSource t m + , MonadHold t m + , AttrGetC info object attr value + , GObject object + , KnownSymbol (AttrLabel info) + ) + => object + -> AttrLabelProxy attr + -> m (Dynamic t value) +dynamicOnAttribute = dynamicFromAttributeWith on FireSync diff --git a/src/Reflex/GI/Gtk/Output.hs b/src/Reflex/GI/Gtk/Output.hs --- a/src/Reflex/GI/Gtk/Output.hs +++ b/src/Reflex/GI/Gtk/Output.hs @@ -5,12 +5,26 @@ {-# LANGUAGE RankNTypes, KindSignatures, DataKinds, ConstraintKinds, FlexibleContexts, GADTs #-} {-# LANGUAGE FunctionalDependencies, FlexibleInstances #-} +{-| +Description : Output reactive values to attributes of GTK widgets +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides helpers for outputting 'Event's or 'Dynamic's to +attributes of GTK 'GI.Gtk.Widget's (or any other object that has +attributes). +-} module Reflex.GI.Gtk.Output - ( Sinkable(toSinkEvent) - , MonadGtkSink + ( sink , sink1 - , sink , ReactiveAttrOp(..) + , Sinkable( sinkPostBuild + , sinkUpdates + , toSinkEvent + ) + , MonadGtkSink ) where import Data.GI.Base.Attributes ( AttrBaseTypeConstraint @@ -32,12 +46,14 @@ import Data.GI.Base.Overloading ( HasAttributeList , ResolveAttribute ) +import Data.Witherable (catMaybes) import GHC.TypeLits (Symbol) import Reflex ( Dynamic , Event , PerformEvent , Performable , PostBuild + , Reflex , (<@) , current , getPostBuild @@ -49,25 +65,68 @@ , runGtk ) +-- | This constraint is necessary for output operations to GTK +-- widgets. Note that it is a subclass of +-- 'Reflex.GI.Gtk.Class.MonadReflexGtk' and implemented by +-- 'Reflex.GI.Gtk.Host.ReflexGtk'. type MonadGtkSink t m = ( PerformEvent t m , PostBuild t m , MonadRunGtk (Performable m) ) -class Sinkable t s | s -> t where - toSinkEvent :: (MonadGtkSink t m) => s a -> m (Event t a) +-- | This is a typeclass for reactive values that that can give +-- notifications about updates and thus be used to trigger actions in +-- the real world based on those updates. +class (Functor s) => Sinkable t s | s -> t where + -- | Turn the reactive value into an event that fires at post build + -- time 'Just' the current value or 'Nothing' if no value is + -- available at post build time. + sinkPostBuild :: (PostBuild t m) => s a -> m (Event t (Maybe a)) -instance Sinkable t (Event t) where - toSinkEvent = pure + -- | Turn the reactive value into an event that fires the new value + -- whenever it is changed. This should not include 'sinkPostBuild' + -- itself, though it may coincide with it, when the value changes at + -- post build time. + sinkUpdates :: (Reflex t) => s a -> Event t a -instance Sinkable t (Dynamic t) where - toSinkEvent d = do - postBuild <- getPostBuild - pure $ leftmost - [ updated d - , current d <@ postBuild + -- | Turn the reactive value into an event that fires when the + -- available for the first time (possibly at post build time) and + -- whenever the value is replaced afterwards. This can be thought of + -- as a combination of 'sinkPostBuild' and 'sinkUpdates'. + toSinkEvent :: (PostBuild t m) => s a -> m (Event t a) + toSinkEvent s = + (\initial -> leftmost + [ sinkUpdates s + , catMaybes initial ] + ) <$> sinkPostBuild s +-- | An Event has no value available at post build time, but is +-- updated whenever it fires. +instance (Reflex t) => Sinkable t (Event t) where + sinkPostBuild _ = (Nothing <$) <$> getPostBuild + sinkUpdates = id + toSinkEvent = pure + +-- | A dynamic has a value at post build time and can be updated +-- later. +instance (Functor (Dynamic t)) => Sinkable t (Dynamic t) where + sinkPostBuild s = (Just <$> current s <@) <$> getPostBuild + sinkUpdates = updated + +-- | Arranges that a given attribute is kept in sync with a reactive +-- value on a given object, i.e. +-- +-- @sink1 labelWidget '$' #label :== reactiveLabelText@ +-- +-- will arrange that the attribute @#label@ on +-- @labelWidget@ will always be updated to the value of +-- @reactiveLabelText@. +-- +-- Essentially the single value case of 'sink'. +-- +-- Alos see the note on 'sink' for updated from more than one source +-- to the targeted attribute. sink1 :: (MonadGtkSink t m) => object -> ReactiveAttrOp t object 'AttrSet @@ -77,7 +136,9 @@ toSinkEvent updates >>= performEvent_ . fmap (\x -> runGtk $ set object [plainOp x]) infixr 0 :==, :==>, :~~, :~~> +-- | Reactive pendant to 'AttrOp'. data ReactiveAttrOp t obj (tag :: AttrOpTag) where + -- | Reactive pendant to ':='. (:==) :: ( HasAttributeList obj , info ~ ResolveAttribute attr obj , AttrInfo info @@ -89,6 +150,7 @@ => AttrLabelProxy (attr :: Symbol) -> s a -> ReactiveAttrOp t obj tag + -- | Reactive pendant to ':=>'. (:==>) :: ( HasAttributeList obj , info ~ ResolveAttribute attr obj , AttrInfo info @@ -100,6 +162,7 @@ => AttrLabelProxy (attr :: Symbol) -> s (IO a) -> ReactiveAttrOp t obj tag + -- | Reactive pendant to ':~'. (:~~) :: ( HasAttributeList obj , info ~ ResolveAttribute attr obj , AttrInfo info @@ -114,6 +177,7 @@ => AttrLabelProxy (attr :: Symbol) -> s (a -> a) -> ReactiveAttrOp t obj tag + -- | Reactive pendant to ':~>'. (:~~>) :: ( HasAttributeList obj , info ~ ResolveAttribute attr obj , AttrInfo info @@ -129,6 +193,11 @@ -> s (a -> IO a) -> ReactiveAttrOp t obj tag +-- | Splits the type information from a 'ReactiveAttrOp' into the +-- underlying 'AttrOp' and the 'Sinkable'. This makes it easier to use +-- the underlying 'AttrOp' with its associated operations and +-- established the mapping of the constructors of 'ReactiveAttrOp' and +-- those of 'AttrOp'. withReactiveAttrOp :: ReactiveAttrOp t obj tag -> (forall a s. Sinkable t s => (a -> AttrOp obj tag) -> s a -> b) -> b @@ -137,6 +206,23 @@ withReactiveAttrOp (attr :~~ updates) f = f (attr :~) updates withReactiveAttrOp (attr :~~> updates) f = f (attr :~>) updates +-- | A reactive version of 'set'. +-- +-- For example +-- +-- @sink object [#attr1 :== attr1Dynamic, #attr2 :== attr2Event]@ +-- +-- Will arrange that @#attr1@ is updated to the current value of +-- @attr1Dynamic@ whenever it is updated, just as @#attr2@ will always +-- be updated to the value of @attr2Event@ whenever it fires. +-- +-- When a single attribute is changed by multiple sources, (such as +-- different calls to 'sink', 'sink1', specifying the same attribute +-- multiple times in the same call to 'sink', or manual updates +-- through 'set') the most recent update wins (until a newer update +-- occurs). However, you should generally not rely on this and instead +-- make sure that at most one call to 'sink' or 'sink1' targets the +-- same attribute. sink :: ( MonadGtkSink t m ) => object -> [ReactiveAttrOp t object 'AttrSet] -> m () diff --git a/src/Reflex/GI/Gtk/Run.hs b/src/Reflex/GI/Gtk/Run.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Run.hs @@ -0,0 +1,21 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at https://mozilla.org/MPL/2.0/. + +{-| +Description : Run IO actions in GTK context in the face of threading +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides a monadic context for predictably executing 'IO' +actions that need acces to the GTK context (basically everything from +'GI.Gtk' and similar) in situations where code is executed in a +different thread than the GTK thread. +-} +module Reflex.GI.Gtk.Run + ( module Reflex.GI.Gtk.Run.Class + ) where + +import Reflex.GI.Gtk.Run.Class diff --git a/src/Reflex/GI/Gtk/Run/Base.hs b/src/Reflex/GI/Gtk/Run/Base.hs --- a/src/Reflex/GI/Gtk/Run/Base.hs +++ b/src/Reflex/GI/Gtk/Run/Base.hs @@ -9,10 +9,13 @@ module Reflex.GI.Gtk.Run.Base ( RunGtkT , runGtkT + , askRunGtk + , askRunGtk_ + , askRunGtkPromise + , askMakeSynchronousFire ) where -import Control.Concurrent ( ThreadId - , myThreadId +import Control.Concurrent ( isCurrentThreadBound , newEmptyMVar , putMVar , readMVar @@ -54,6 +57,9 @@ ) import Control.Monad.Trans (MonadTrans) import Data.Function (fix) +import GI.GLib ( Thread + , threadSelf + ) import GI.GLib.Constants ( pattern PRIORITY_HIGH_IDLE , pattern SOURCE_REMOVE ) @@ -74,9 +80,9 @@ ) , PerformEventT ) -import Reflex.GI.Gtk.Run.Class (MonadRunGtk( askRunGtk_ - , askRunGtkPromise - , askMakeSynchronousFire +import Reflex.GI.Gtk.Run.Class (MonadRunGtk( runGtk + , runGtk_ + , runGtkPromise ) ) import Reflex.Host.Class ( MonadReflexCreateTrigger @@ -87,11 +93,11 @@ data RunGtkEnv = RunGtkEnv { actionQueue :: TChan (IO ()) - , gtkThreadId :: ThreadId + , gtkThread :: Thread , waitEventThreadException :: STM SomeException } -newtype RunGtkT t m a = RunGtkT +newtype RunGtkT m a = RunGtkT { unGtkT :: ReaderT RunGtkEnv m a } deriving ( Functor @@ -104,14 +110,14 @@ , MonadFix ) -deriving instance MonadSubscribeEvent t m => MonadSubscribeEvent t (RunGtkT t m) -deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RunGtkT t m) -deriving instance MonadReflexHost t m => MonadReflexHost t (RunGtkT t m) -deriving instance MonadSample t m => MonadSample t (RunGtkT t m) -deriving instance MonadHold t m => MonadHold t (RunGtkT t m) -deriving instance NotReady t m => NotReady t (RunGtkT t m) +deriving instance MonadSubscribeEvent t m => MonadSubscribeEvent t (RunGtkT m) +deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RunGtkT m) +deriving instance MonadReflexHost t m => MonadReflexHost t (RunGtkT m) +deriving instance MonadSample t m => MonadSample t (RunGtkT m) +deriving instance MonadHold t m => MonadHold t (RunGtkT m) +deriving instance NotReady t m => NotReady t (RunGtkT m) -instance Adjustable t m => Adjustable t (RunGtkT t m) where +instance Adjustable t m => Adjustable t (RunGtkT m) where runWithReplace (RunGtkT a) e = RunGtkT $ runWithReplace a $ unGtkT <$> e traverseIntMapWithKeyWithAdjust f m a = RunGtkT $ traverseIntMapWithKeyWithAdjust f' m a where f' k v = unGtkT $ f k v @@ -120,35 +126,48 @@ traverseDMapWithKeyWithAdjustWithMove f m e = RunGtkT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unGtkT $ f k v) m e -instance PerformEvent t m => PerformEvent t (RunGtkT t m) where - type Performable (RunGtkT t m) = RunGtkT t (Performable m) +instance PerformEvent t m => PerformEvent t (RunGtkT m) where + type Performable (RunGtkT m) = RunGtkT (Performable m) performEvent = RunGtkT . performEvent . fmap unGtkT performEvent_ = RunGtkT . performEvent_ . fmap unGtkT -instance (MonadIO m) => MonadRunGtk (RunGtkT t m) where - askRunGtk_ = do - actionChan <- RunGtkT $ asks actionQueue - gtkTId <- RunGtkT $ asks gtkThreadId - pure $ \a -> do - myTId <- myThreadId - let execute = if myTId == gtkTId - then id - else scheduleAction actionChan - execute $ void a - askRunGtkPromise = do +instance (MonadIO m) => MonadRunGtk (RunGtkT m) where + runGtk a = askRunGtk >>= liftIO . ($a) + runGtk_ a = askRunGtk_ >>= liftIO . ($a) + runGtkPromise a = askRunGtkPromise >>= liftIO . fmap liftIO . ($a) + +askRunGtk :: (Monad m) => RunGtkT m (IO a -> IO a) +askRunGtk = (join .) <$> askRunGtkPromise + +askRunGtk_ :: (Monad m) => RunGtkT m (IO a -> IO ()) +askRunGtk_ = do + actionChan <- RunGtkT $ asks actionQueue + gtkThread' <- RunGtkT $ asks gtkThread + pure $ \a -> do + iAmGuiThread <- isThreadMe gtkThread' + let execute = if iAmGuiThread + then id + else scheduleAction actionChan + execute $ void a + +askRunGtkPromise :: (Monad m) => RunGtkT m (IO a -> IO (IO a)) +askRunGtkPromise = do actionQueue <- RunGtkT $ asks actionQueue - gtkTId <- RunGtkT $ asks gtkThreadId + gtkThread' <- RunGtkT $ asks gtkThread pure $ \a -> do - myTId <- myThreadId - if myTId == gtkTId + iAmGtkThread <- isThreadMe gtkThread' + if iAmGtkThread then pure <$> a else do answerMVar <- newEmptyMVar scheduleAction actionQueue $ try @SomeException a >>= putMVar answerMVar pure $ readMVar answerMVar >>= either throwIO pure - askMakeSynchronousFire = do + +askMakeSynchronousFire :: (Monad m) => RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ()) +askMakeSynchronousFire = do actionChan <- RunGtkT $ asks actionQueue waitEventThreadException' <- RunGtkT $ asks waitEventThreadException + gtkThread' <- RunGtkT $ asks gtkThread pure $ \fireAsynchronously x -> do firedTVar <- newTVarIO False fireAsynchronously x $ atomically $ writeTVar firedTVar True @@ -157,14 +176,28 @@ if hasFired then pure () else retry + iAmGtkThread <- isThreadMe gtkThread' fix $ \loop -> join $ atomically $ (pure () <$ waitCompleted) - `orElse` ( do + `orElse` ( if iAmGtkThread + then do gtkAction <- readTChan actionChan pure $ runGtkAction gtkAction >> loop + else retry -- If we're run outside the GTK thread, + -- we shouldn't runGTk actions. ) `orElse` (waitEventThreadException' >>= throwSTM) +isThreadMe :: Thread -> IO Bool +isThreadMe refThread = do + iAmBound <- isCurrentThreadBound + if iAmBound + then do + myThread <- threadSelf + pure $ myThread == refThread + else pure False -- If we are not bound, we can't reliably be any + -- OS thread. + scheduleAction :: TChan (IO ()) -> IO () -> IO () scheduleAction actionChan action = atomically (writeTChan actionChan action) @@ -181,16 +214,16 @@ runGtkAction a = mask_ $ catch a (const $ pure () :: SomeException -> IO ()) runGtkT :: (MonadIO m) - => RunGtkT t m a + => RunGtkT m a -> STM SomeException - -> ThreadId + -> Thread -> m a -runGtkT (RunGtkT a) waitEventThreadException gtkThreadId = do +runGtkT (RunGtkT a) waitEventThreadException gtkThread = do actionQueue <- liftIO newTChanIO runReaderT a RunGtkEnv{..} instance ( NotReady t m , ReflexHost t - ) => NotReady t (PerformEventT t (RunGtkT t m)) where + ) => NotReady t (PerformEventT t (RunGtkT m)) where notReady = pure () notReadyUntil _ = pure () diff --git a/src/Reflex/GI/Gtk/Run/Class.hs b/src/Reflex/GI/Gtk/Run/Class.hs --- a/src/Reflex/GI/Gtk/Run/Class.hs +++ b/src/Reflex/GI/Gtk/Run/Class.hs @@ -2,54 +2,66 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at https://mozilla.org/MPL/2.0/. -{-# LANGUAGE TypeApplications, DefaultSignatures, StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Reflex.GI.Gtk.Run.Class - ( MonadRunGtk( askRunGtk_ - , askRunGtk - , askRunGtkPromise - , askMakeSynchronousFire + ( MonadRunGtk( runGtk_ + , runGtk + , runGtkPromise ) - , runGtk_ - , runGtk - , runGtkPromise ) where import Control.Monad (join) -import Control.Monad.IO.Class ( MonadIO - , liftIO - ) -import Control.Monad.Reader (ReaderT(ReaderT)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ReaderT) import Control.Monad.Trans (lift) -import Reflex ( PostBuildT(PostBuildT) - , TriggerEventT(TriggerEventT) +import Reflex ( PostBuildT + , TriggerEventT ) +-- | Typeclass for 'Monad's that give the ability to run IO actions in +-- the proper context for calling GTK functions. Most notably, this +-- means that the IO action is run in the thread that GTK was +-- initialized in. class (MonadIO m) => MonadRunGtk m where - askRunGtk :: m (IO a -> IO a) - askRunGtk = (join .) <$> askRunGtkPromise + -- | Execute the given 'IO' action in the correct context for + -- calling GTK actions. This might mean executing the action in a + -- different thread if the current thread is not the GTK thread, but + -- it might also mean executing the action in the current thread if + -- the current thread is the GTK thread. + runGtk :: IO a -> m a + runGtk = join . runGtkPromise - askRunGtk_ :: m (IO a -> IO ()) + -- | Like 'runGtk' but does not return the result of the executed + -- action and will not wait for the action to finish executing if it + -- is run in a different thread. + -- + -- Note that it is not precisely specified under which circumstances + -- will be executed asynchronously in a different thread or + -- synchronously in the current thread, so you should either account + -- for both possibilities or use 'runGtk' to always wait + -- synchronously wait for the action to finish. + runGtk_ :: IO a -> m () - askRunGtkPromise :: m (IO a -> IO (IO a)) + -- | Like 'runGtk' but does not wait for the 'IO' action to finish + -- executing. Instead it returns another monadic action that waits + -- for the action to finish and returns its result. + -- + -- Note that just as with 'runGtk_' it is not exactly specified + -- under which circumstances the action will be run asynchronously + -- or synchronously. You should either account for both cases or use + -- 'runGtk' to always wait for the action to finish. + runGtkPromise :: IO a -> m (m a) - askMakeSynchronousFire :: m ((a -> IO () -> IO ()) -> a -> IO ()) +instance MonadRunGtk m => MonadRunGtk (PostBuildT t m) where + runGtk = lift . runGtk + runGtk_ = lift . runGtk_ + runGtkPromise = fmap lift . lift . runGtkPromise -deriving instance MonadRunGtk m => MonadRunGtk (PostBuildT t m) -deriving instance MonadRunGtk m => MonadRunGtk (TriggerEventT t m) +instance MonadRunGtk m => MonadRunGtk (TriggerEventT t m) where + runGtk = lift . runGtk + runGtk_ = lift . runGtk_ + runGtkPromise = fmap lift . lift . runGtkPromise instance MonadRunGtk m => MonadRunGtk (ReaderT r m) where - askRunGtk = lift askRunGtk - askRunGtk_ = lift askRunGtk_ - askRunGtkPromise = lift askRunGtkPromise - askMakeSynchronousFire = lift askMakeSynchronousFire - -runGtk :: (MonadRunGtk m) => IO a -> m a -runGtk a = askRunGtk >>= liftIO . ($a) - -runGtk_ :: (MonadRunGtk m) => IO a -> m () -runGtk_ a = askRunGtk_ >>= liftIO . ($a) - -runGtkPromise :: (MonadRunGtk m) => IO a -> m (m a) -runGtkPromise a = askRunGtkPromise >>= liftIO . fmap liftIO . ($a) + runGtk = lift . runGtk + runGtk_ = lift . runGtk_ + runGtkPromise = fmap lift . lift . runGtkPromise diff --git a/src/Reflex/GI/Gtk/Widget.hs b/src/Reflex/GI/Gtk/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Widget.hs @@ -0,0 +1,23 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at https://mozilla.org/MPL/2.0/. + +{-| +Description : Reactive helpers for specific GTK widgets +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module re-exports helpers for various kinds of GTK widgets from +its submodules. +-} +module Reflex.GI.Gtk.Widget + ( module Reflex.GI.Gtk.Widget.Bin + , module Reflex.GI.Gtk.Widget.Box + , module Reflex.GI.Gtk.Widget.Utils + ) where + +import Reflex.GI.Gtk.Widget.Bin +import Reflex.GI.Gtk.Widget.Box +import Reflex.GI.Gtk.Widget.Utils diff --git a/src/Reflex/GI/Gtk/Widget/Bin.hs b/src/Reflex/GI/Gtk/Widget/Bin.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Widget/Bin.hs @@ -0,0 +1,62 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at https://mozilla.org/MPL/2.0/. + +{-# LANGUAGE FlexibleContexts #-} + +{-| +Description : Reactive helpers for 'Bin's +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides helpers for dealing with 'Bin's in reactive +contexts. +-} +module Reflex.GI.Gtk.Widget.Bin + ( sinkBin + ) where + +import Data.GI.Base (GObject) +import Data.GI.Base.Overloading (IsDescendantOf) +import GI.Gtk ( Bin + , Container + , Widget + , binGetChild + , containerAdd + , containerRemove + ) +import Reflex ( PerformEvent + , Performable + , PostBuild + , performEvent_ + ) +import Reflex.GI.Gtk.Output ( Sinkable + , toSinkEvent + ) +import Reflex.GI.Gtk.Run.Class ( MonadRunGtk + , runGtk + ) + +-- | Display a single reactively changing widget inside a 'Bin'. +sinkBin :: ( MonadRunGtk (Performable m) + , PerformEvent t m + , PostBuild t m + , Sinkable t s + , GObject bin + , IsDescendantOf Bin bin + , IsDescendantOf Container bin + , GObject widget + , IsDescendantOf Widget widget + ) + => bin + -- ^ The bin to display the widget in + -> s widget + -- ^ The changing widget to display + -> m () +sinkBin bin sinkableWidget = + performEvent_ . fmap (\widget -> runGtk + $ binGetChild bin >>= mapM_ (containerRemove bin) + >> containerAdd bin widget + ) =<< toSinkEvent sinkableWidget diff --git a/src/Reflex/GI/Gtk/Widget/Box.hs b/src/Reflex/GI/Gtk/Widget/Box.hs --- a/src/Reflex/GI/Gtk/Widget/Box.hs +++ b/src/Reflex/GI/Gtk/Widget/Box.hs @@ -4,6 +4,16 @@ {-# LANGUAGE FlexibleContexts, LambdaCase, TupleSections #-} +{-| +Description : Reactive helpers for 'Box'es +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides helpers for dealing with 'Box'es in reactive +contexts. +-} module Reflex.GI.Gtk.Widget.Box ( sinkBox , sinkBoxUniform @@ -35,19 +45,18 @@ , boxReorderChild , boxSetChildPacking , containerRemove - , widgetShowAll ) -import Reflex ( Dynamic +import Reflex ( MonadHold , PerformEvent , Performable , PostBuild - , (<@) , (<@>) - , current , performEvent_ - , getPostBuild - , updated + , hold ) +import Reflex.GI.Gtk.Output ( Sinkable + , toSinkEvent + ) import Reflex.GI.Gtk.Run.Class ( MonadRunGtk , runGtk ) @@ -68,6 +77,10 @@ boxPackStart box child expand fill padding boxSetChildPacking box child expand fill padding unknownPackType +-- | Pack a dynamically changing sequence of widgets into a box. Each +-- widget has individual dynamic packing parameters. +-- +-- The widgets will be packed into the 'Box' in left-fold order. sinkBox :: ( GObject box , IsDescendantOf Container box , IsDescendantOf Box box @@ -78,21 +91,27 @@ , Eq w , PerformEvent t m , PostBuild t m + , MonadHold t m , MonadRunGtk m , MonadRunGtk (Performable m) + , Sinkable t s ) => box - -> Dynamic t (f (w, Bool, Bool, Word32, PackType)) + -- ^ The 'Box' to pack into + -> s (f (w, Bool, Bool, Word32, PackType)) + -- ^ The dynamic sequence of 'Widget's. The arguments are the + -- same as those for 'boxSetChildPacking'. -> m () -sinkBox box widgets = do - performEvent_ $ update <$> current widgets <@> updated widgets - postBuild <- getPostBuild - performEvent_ - $ runGtk . foldl' (\acc (w, expand, fill, padding, packType) -> - acc >> pack box w expand fill padding packType - ) (pure ()) - <$> current widgets <@ postBuild - where update olds neww = +sinkBox box widgetSinkable = do + widgetUpdates <- toSinkEvent widgetSinkable + currentWidgets <- hold Nothing $ Just <$> widgetUpdates + performEvent_ $ update <$> currentWidgets <@> widgetUpdates + where update Nothing widgets = + runGtk $ foldl' (\acc (w, expand, fill, padding, packType) -> + acc + >> pack box w expand fill padding packType + ) (pure ()) widgets + update (Just olds) neww = let (reorder, _, removed) = foldl' (\wacc -> \case This old -> markOld wacc old @@ -126,7 +145,6 @@ _ <- acc pack box w expand fill padding packType boxReorderChild box w i - widgetShowAll w , succ i , oldWidgets ) @@ -147,6 +165,8 @@ , M.delete (OrdWidget w) oldWidgets ) w oldPacking (expand, fill, padding, packType) +-- | Like 'sinkBox', but the packing parameters are statically +-- specified for all widgets. sinkBoxUniform :: ( GObject box , IsDescendantOf Container box , IsDescendantOf Box box @@ -159,9 +179,13 @@ , PostBuild t m , MonadRunGtk m , MonadRunGtk (Performable m) + , MonadHold t m + , Sinkable t s ) => box - -> Dynamic t (f w) + -- ^ The 'Box' to pack into + -> s (f w) + -- ^ The dynamic sequence of 'Widget's -> Bool -> Bool -> Word32 diff --git a/src/Reflex/GI/Gtk/Widget/Ord.hs b/src/Reflex/GI/Gtk/Widget/Ord.hs --- a/src/Reflex/GI/Gtk/Widget/Ord.hs +++ b/src/Reflex/GI/Gtk/Widget/Ord.hs @@ -2,8 +2,6 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at https://mozilla.org/MPL/2.0/. -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} - module Reflex.GI.Gtk.Widget.Ord ( OrdWidget(..) ) where diff --git a/src/Reflex/GI/Gtk/Widget/Utils.hs b/src/Reflex/GI/Gtk/Widget/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Widget/Utils.hs @@ -0,0 +1,74 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at https://mozilla.org/MPL/2.0/. + +{-# LANGUAGE OverloadedLabels #-} + +{-| +Description : Miscellaneous 'Widget' helpers +Copyright : Sven Bartscher 2020 +License : MPL-2.0 +Maintainer : sven.bartscher@weltraumschlangen.de +Stability : experimental + +This module provides miscellaneous helpers for dealing with GTK +'Widget's in reactive contexts. +-} +module Reflex.GI.Gtk.Widget.Utils + ( holdNotReadyWidget + , holdNotReadyDynamicWidget + , notReadyWidget + ) where + +import Control.Monad (join) +import GI.Gtk ( Widget + , spinnerNew + , toWidget + ) +import Reflex ( Dynamic + , Event + , MonadHold + , Reflex + , holdDyn + ) +import Reflex.GI.Gtk.Run.Class ( MonadRunGtk + , runGtk + ) + +-- | A widget appropriate for displaying in place of widgets that +-- aren't available yet, e.g. as replacement for widgets that aren't +-- available until post-build time. +-- +-- The current implementation returns a 'GI.Gtk.Spinner' that has been +-- started ('GI.Gtk.spinnerStart'). +-- +-- Note that the widget is not 'GI.Gtk.widgetShow'n in this +-- function. If you want the 'Widget' to be actually shown, you should +-- call 'GI.Gtk.widgetShow' explicitly on it. +notReadyWidget :: IO Widget +notReadyWidget = do + spinner <- spinnerNew + #start spinner + toWidget spinner + +-- | Hold an 'Event' firing 'Widget's in a 'Dynamic', automatically +-- using a 'notReadyWidget' as the initial value. +holdNotReadyWidget :: ( MonadRunGtk m + , MonadHold t m + ) + => Event t Widget -> m (Dynamic t Widget) +holdNotReadyWidget newWidget = do + spinner <- runGtk notReadyWidget + holdDyn spinner newWidget + +-- | A variant of 'holdNotReadyWidget' where 'Widget's aren't replaced +-- directly, but instead different @'Dynamic' t 'Widget'@s are +-- switched in. +holdNotReadyDynamicWidget :: ( MonadRunGtk m + , MonadHold t m + , Reflex t + ) + => Event t (Dynamic t Widget) -> m (Dynamic t Widget) +holdNotReadyDynamicWidget newWidget = do + spinner <- runGtk notReadyWidget + join <$> holdDyn (pure spinner) newWidget diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,27 @@ +resolver: lts-16.27 + +packages: + - . + +extra-deps: + - reflex-0.8.0.0 + - constraints-extras-0.3.0.2 + - dependent-map-0.4.0.0 + - dependent-sum-0.7.1.0 + - monoidal-containers-0.6.0.1 + - patch-0.0.3.2 + - prim-uniq-0.2 + - ref-tf-0.4.0.2 + - witherable-0.3.5 + - haskell-gi-base-0.24.5 + - haskell-gi-0.24.7 + - gi-pango-1.0.23 + - gi-harfbuzz-0.0.3 + - gi-gtk-3.0.36 + - gi-gobject-2.0.25 + - gi-glib-2.0.24 + - gi-gio-2.0.27 + - gi-gdkpixbuf-2.0.24 + - gi-gdk-3.0.23 + - gi-cairo-1.0.24 + - gi-atk-2.0.22 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,159 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: reflex-0.8.0.0@sha256:e50de03568818072e2811211431ffe9811aeed69f3b24104b1dafb1b6fd0a525,11942 + pantry-tree: + size: 4587 + sha256: 41a690372195eecda7bc9631a3724bc8a60a47a765e5c4e7a7ef8bdaf6a6eae9 + original: + hackage: reflex-0.8.0.0 +- completed: + hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + pantry-tree: + size: 594 + sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1 + original: + hackage: constraints-extras-0.3.0.2 +- completed: + hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + pantry-tree: + size: 551 + sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5 + original: + hackage: dependent-map-0.4.0.0 +- completed: + hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + pantry-tree: + size: 290 + sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50 + original: + hackage: dependent-sum-0.7.1.0 +- completed: + hackage: monoidal-containers-0.6.0.1@sha256:ffdfae0fde7a08e9e314667a78d86454d2d23137d85f226ec6e757c190fb28ad,2583 + pantry-tree: + size: 569 + sha256: 61d5a73cb768aa4d59db7365418a2fc1bb24b8c3e53ca496372656b6ba4d31ab + original: + hackage: monoidal-containers-0.6.0.1 +- completed: + hackage: patch-0.0.3.2@sha256:b4d3a60db88a04030392a06076defb9fe310a79577df7ff63ea2bb0298817b8d,2452 + pantry-tree: + size: 977 + sha256: b9ab71b93cdff84a75c9d251513b4d64a9fea5b89526ecbec60eb9ae04521478 + original: + hackage: patch-0.0.3.2 +- completed: + hackage: prim-uniq-0.2@sha256:7bfd8a729812bf212610b63459b76a086ecd5ce48f48d785c288e082d055d47b,1403 + pantry-tree: + size: 464 + sha256: aa27fb2f22141bd9bb474091f811badd9c71c52a1504fb81834aeb28cecff626 + original: + hackage: prim-uniq-0.2 +- completed: + hackage: ref-tf-0.4.0.2@sha256:69de3550250e0cd69f45d080359cb314a9487c915024349c75b78732bbee9332,1134 + pantry-tree: + size: 211 + sha256: fc5a4a35b4c782a33f452c1dc66ffa8ddbf321e2db369bd8823c796f0d4d8c7f + original: + hackage: ref-tf-0.4.0.2 +- completed: + hackage: witherable-0.3.5@sha256:6590a15735b50ac14dcc138d4265ff1585d5f3e9d3047d5ebc5abf4cd5f50084,1476 + pantry-tree: + size: 271 + sha256: b99f21dbac28da031eb7c787fbffbe5e77e0aee42b64b5dda082470e907d5ab5 + original: + hackage: witherable-0.3.5 +- completed: + hackage: haskell-gi-base-0.24.5@sha256:f289ee14d99bc91daaf15a72533def379e1f5c6e51e9eff0d67e57912816ce74,2435 + pantry-tree: + size: 1937 + sha256: ddb1858a395755bb14438f39718df2f95042f492a55b6dc0f9343435f758613c + original: + hackage: haskell-gi-base-0.24.5 +- completed: + hackage: haskell-gi-0.24.7@sha256:d1cf3e64589c9c366228f8fe89d2d48207b3ca11b48966ef976fedfa679a819b,5241 + pantry-tree: + size: 4348 + sha256: c6db02339d61f70cfb687c7786c4441b9fa2658ce4b4aac19395f2e939ed8f1b + original: + hackage: haskell-gi-0.24.7 +- completed: + hackage: gi-pango-1.0.23@sha256:160443e93def8aa95e66fe1de40d51bb12ee922f7cafe6e33d6009f5490c66c5,8233 + pantry-tree: + size: 360 + sha256: fc5b1f6835549f148284950ab540df9d9f4d7a75df958b5de5e4c01d922dcb37 + original: + hackage: gi-pango-1.0.23 +- completed: + hackage: gi-harfbuzz-0.0.3@sha256:0550f498854b7edac66b1a09f283e5b5c86033aff58b4ac30b024ae59e1bd866,5869 + pantry-tree: + size: 364 + sha256: f33e284484ab7520bb115508fe1ddae5585e42aa292c97f4f6abb2e7ec3d60eb + original: + hackage: gi-harfbuzz-0.0.3 +- completed: + hackage: gi-gtk-3.0.36@sha256:ed4525766763f290aa03ae19e41a31c429a8d381729d4869e7c44e551351df6a,39016 + pantry-tree: + size: 359 + sha256: cd1718b99526699f158dce646c2c20cf51eedca7f78c33f8d6290e2ba46ccbb4 + original: + hackage: gi-gtk-3.0.36 +- completed: + hackage: gi-gobject-2.0.25@sha256:95ca4fd52538ad9b41e54fc9324a93fd680052f8ebb25811e3dc6f8a94bff009,9349 + pantry-tree: + size: 364 + sha256: 3187d2ae59029b353e1fa134cd7716e4602483d2f1b86fee02c957b4a0065e2b + original: + hackage: gi-gobject-2.0.25 +- completed: + hackage: gi-glib-2.0.24@sha256:46726f0fb6b0ef0d6f6620d53025a9ca2a5bc273ab65496b368df7bc3dbe6d83,9558 + pantry-tree: + size: 358 + sha256: b51e43df984a63058ca529a99875a3c42a37827cf11694542abf77586cf28532 + original: + hackage: gi-glib-2.0.24 +- completed: + hackage: gi-gio-2.0.27@sha256:6535951e2ad0882bc7231da56457be52a85e99cb56acec9ec9919f1c15bed728,21981 + pantry-tree: + size: 359 + sha256: 75d3bd5fc1f9c00268537219d309ca289666da051835f6813bb636cebf4f1191 + original: + hackage: gi-gio-2.0.27 +- completed: + hackage: gi-gdkpixbuf-2.0.24@sha256:287c7233cfecb69a6aff0fb6a952862d759b5562b488bb8046229ee0f4372c6f,3842 + pantry-tree: + size: 368 + sha256: 9819be48b98d91cc69d84a9cc7c997262443e1c4d37a224a3a2f12b55c877740 + original: + hackage: gi-gdkpixbuf-2.0.24 +- completed: + hackage: gi-gdk-3.0.23@sha256:33ad689aa6e1463c57946762016a789b6cb663df174e31f9705956a9385b7b0f,9003 + pantry-tree: + size: 355 + sha256: 11ff63701019ed413a143b84849f058a83770ba251c8f5743a7edf5d252a1049 + original: + hackage: gi-gdk-3.0.23 +- completed: + hackage: gi-cairo-1.0.24@sha256:451ba2f6f0954805c6d38f1e0bffd849607160e824abf4e077a95e999ef237dd,3727 + pantry-tree: + size: 358 + sha256: 3e8d149deabf1894faec5b3e9e35869ad8174f911be659c9766b183b92770994 + original: + hackage: gi-cairo-1.0.24 +- completed: + hackage: gi-atk-2.0.22@sha256:6ec2197aee4a1b5966302fc2875be05a9b3a54f694c4a6a9a330f4b0211223c5,6791 + pantry-tree: + size: 355 + sha256: b1398e06f447003ef9c9dde64ebae1cab214db2b20a179a85837604ddb0ac12b + original: + hackage: gi-atk-2.0.22 +snapshots: +- completed: + size: 533252 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml + sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73 + original: lts-16.27