{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE LambdaCase #-}

-- | Internal helpers for applying attributes and signal handlers to GTK+
-- widgets.
module GI.Gtk.Declarative.Attributes.Internal
  ( addSignalHandler
  )
where

import           Control.Monad                  ( (>=>) )
import           Control.Monad.IO.Class         ( MonadIO )
import qualified GI.GObject                    as GI
import qualified GI.Gtk                        as Gtk

import           GI.Gtk.Declarative.Attributes
import           GI.Gtk.Declarative.Attributes.Internal.Conversions
import           GI.Gtk.Declarative.EventSource

addSignalHandler
  :: (Gtk.IsWidget widget, MonadIO m)
  => (event -> IO ())
  -> widget
  -> Attribute widget event
  -> m Subscription
addSignalHandler :: (event -> IO ())
-> widget -> Attribute widget event -> m Subscription
addSignalHandler onEvent :: event -> IO ()
onEvent widget' :: widget
widget' = Attribute widget event -> m (Maybe CULong)
listenToSignal (Attribute widget event -> m (Maybe CULong))
-> (Maybe CULong -> m Subscription)
-> Attribute widget event
-> m Subscription
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
  Just eh :: CULong
eh -> CULong -> m Subscription
setupCancellation CULong
eh
  Nothing -> Subscription -> m Subscription
forall (f :: * -> *) a. Applicative f => a -> f a
pure Subscription
forall a. Monoid a => a
mempty
 where
  listenToSignal :: Attribute widget event -> m (Maybe CULong)
listenToSignal = \case
    OnSignalPure signal :: SignalProxy widget info
signal handler :: EventHandler gtkCallback widget 'Pure event
handler ->
      CULong -> Maybe CULong
forall a. a -> Maybe a
Just (CULong -> Maybe CULong) -> m CULong -> m (Maybe CULong)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> widget
-> SignalProxy widget info -> HaskellCallbackType info -> m CULong
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info -> HaskellCallbackType info -> m CULong
Gtk.on widget
widget' SignalProxy widget info
signal (EventHandler gtkCallback widget 'Pure event
-> widget -> (event -> IO ()) -> gtkCallback
forall gtkCallback (purity :: Purity) widget event.
ToGtkCallback gtkCallback purity =>
EventHandler gtkCallback widget purity event
-> widget -> (event -> IO ()) -> gtkCallback
toGtkCallback EventHandler gtkCallback widget 'Pure event
handler widget
widget' event -> IO ()
onEvent)
    OnSignalImpure signal :: SignalProxy widget info
signal handler :: EventHandler gtkCallback widget 'Impure event
handler ->
      CULong -> Maybe CULong
forall a. a -> Maybe a
Just (CULong -> Maybe CULong) -> m CULong -> m (Maybe CULong)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> widget
-> SignalProxy widget info -> HaskellCallbackType info -> m CULong
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info -> HaskellCallbackType info -> m CULong
Gtk.on widget
widget' SignalProxy widget info
signal (EventHandler gtkCallback widget 'Impure event
-> widget -> (event -> IO ()) -> gtkCallback
forall gtkCallback (purity :: Purity) widget event.
ToGtkCallback gtkCallback purity =>
EventHandler gtkCallback widget purity event
-> widget -> (event -> IO ()) -> gtkCallback
toGtkCallback EventHandler gtkCallback widget 'Impure event
handler widget
widget' event -> IO ()
onEvent)
    _ -> Maybe CULong -> m (Maybe CULong)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CULong
forall a. Maybe a
Nothing
  setupCancellation :: CULong -> m Subscription
setupCancellation handlerId :: CULong
handlerId = do
    Widget
w <- widget -> m Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget widget
widget'
    Subscription -> m Subscription
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Subscription
fromCancellation (Widget -> CULong -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsObject a) =>
a -> CULong -> m ()
GI.signalHandlerDisconnect Widget
w CULong
handlerId))