-- 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 #-}

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