reflex-gi-gtk 0.1.0.0 → 0.2.0.0

raw patch · 19 files changed

+1566/−427 lines, 19 filesdep +witherabledep ~asyncdep ~basedep ~containersnew-component:exe:reflex-gi-gtk-example

Dependencies added: witherable

Dependency ranges changed: async, base, containers, dependent-sum, exception-transformers, gi-gdk, gi-glib, gi-gtk, haskell-gi-base, mtl, patch, primitive, ref-tf, reflex, semialign, stm, text, these

Files

• README.md +115/−0
• changelog.md +3/−0
• example/Main.hs +4/−2
• reflex-gi-gtk.cabal +46/−34
• src/Reflex/GI/Gtk.hs +51/−10
• src/Reflex/GI/Gtk/Class.hs +28/−17
• src/Reflex/GI/Gtk/Host.hs +197/−37
• src/Reflex/GI/Gtk/Input.hs +498/−222
• src/Reflex/GI/Gtk/Output.hs +99/−13
• src/Reflex/GI/Gtk/Run.hs +21/−0
• src/Reflex/GI/Gtk/Run/Base.hs +69/−36
• src/Reflex/GI/Gtk/Run/Class.hs +48/−36
• src/Reflex/GI/Gtk/Widget.hs +23/−0
• src/Reflex/GI/Gtk/Widget/Bin.hs +62/−0
• src/Reflex/GI/Gtk/Widget/Box.hs +42/−18
• src/Reflex/GI/Gtk/Widget/Ord.hs +0/−2
• src/Reflex/GI/Gtk/Widget/Utils.hs +74/−0
• stack.yaml +27/−0
• stack.yaml.lock +159/−0

@@ -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.

@@ -0,0 +1,3 @@+# 0.2.0.0++* Initial release

@@ -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 

@@ -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

@@ -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

@@ -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)+                          )

@@ -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"

@@ -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

@@ -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 ()

@@ -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

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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