reflex-gi-gtk-0.2.0.1: src/Reflex/GI/Gtk/Input.hs
-- 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 ConstraintKinds, GADTs, FlexibleContexts, MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-|
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
( -- * Obtaining input from GI signals
-- ** as 'Event's
MonadGtkSource(eventFromSignalWith)
, eventOnSignal
, eventOnSignal0
, eventFromSignalWith0
, eventOnSignal1
, eventFromSignalWith1
, eventOnSignal0R
, eventFromSignalWith0R
, eventOnSignal1R
, eventFromSignalWith1R
-- ** as 'Behavior's
, behaviorOnSignal
, behaviorFromSignalWith
, behaviorOnSignal1
, behaviorFromSignalWith1
, behaviorOnSignal1R
, behaviorFromSignalWith1R
-- ** as 'Dynamic's
, dynamicOnSignal
, dynamicFromSignalWith
, dynamicOnSignal1
, dynamicFromSignalWith1
, dynamicOnSignal1R
, dynamicFromSignalWith1R
-- * Obtaining input from GI attributes
, eventOnAttribute
, eventFromAttributeWith
, behaviorOnAttribute
, behaviorFromAttributeWith
, dynamicOnAttribute
, dynamicFromAttributeWith
-- * Synchronous vs asynchronous event triggers
--
-- $syncvsasync
, FireAsync(..)
-- * Miscellanous
, Registerer
) where
import Data.GI.Base (GObject)
import Data.GI.Base.Attributes ( AttrGetC
, AttrLabel
, AttrLabelProxy
, get
)
import Data.GI.Base.Signals ( GObjectNotifySignalInfo
, HaskellCallbackType
, SignalHandlerId
, SignalInfo
, SignalProxy(PropertyNotify)
, on
)
import GHC.TypeLits (KnownSymbol)
import Reflex ( Behavior
, Dynamic
, Event
, MonadHold
, TriggerEvent
, hold
, holdDyn
)
import Reflex.GI.Gtk.Run.Class ( MonadRunGtk
, runGtk
)
-- | 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@.
-- | 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
-- $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.
-- | 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
)
=> a
-> object
-> SignalProxy object info
-> ((a -> IO ()) -> HaskellCallbackType info)
-> m (Behavior t a)
behaviorOnSignal = behaviorFromSignalWith on FireSync
-- | '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
-- | '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
-- | '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
-- | '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
-- | 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
-- | '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
-- | '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
-- | '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
-- | '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
-- | 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
-- | '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
-- | 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
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
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