{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module GI.Gtk.Declarative.Attributes.Internal.Conversions
  ( ToGtkCallback(..)
  )
where

import           Control.Monad                  ( void )
import           Data.Functor                   ( ($>) )
import           Data.Functor.Identity

import           GI.Gtk.Declarative.Attributes.Internal.EventHandler

-- * GTK+ EventHandler Conversions

-- | Internal class for converting 'EventHandler's to gi-gtk callbacks.
class ToGtkCallback gtkCallback purity where
  -- | Converts an 'EventHandler', i.e. the internal encoding of a pure or an impure
  -- callback, back to a GTK+ callback. Impure callbacks will also receive a
  -- 'widget' as the last argument.
  toGtkCallback
    :: EventHandler gtkCallback widget purity event
    -> widget
    -> (event -> IO ())
    -> gtkCallback

instance ToGtkCallback (IO ()) Pure where
  toGtkCallback :: EventHandler (IO ()) widget 'Pure event
-> widget -> (event -> IO ()) -> IO ()
toGtkCallback (PureEventHandler (OnlyEvent e :: Identity event
e)) _ f :: event -> IO ()
f = IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (event -> IO ()
f (Identity event -> event
forall a. Identity a -> a
runIdentity Identity event
e))

instance ToGtkCallback (IO Bool) Pure where
  toGtkCallback :: EventHandler (IO Bool) widget 'Pure event
-> widget -> (event -> IO ()) -> IO Bool
toGtkCallback (PureEventHandler (ReturnAndEvent re :: Identity (Bool, event)
re)) _ f :: event -> IO ()
f =
    let (r :: Bool
r, e :: event
e) = Identity (Bool, event) -> (Bool, event)
forall a. Identity a -> a
runIdentity Identity (Bool, event)
re in event -> IO ()
f event
e IO () -> Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
r

instance ToGtkCallback (IO ()) Impure where
  toGtkCallback :: EventHandler (IO ()) widget 'Impure event
-> widget -> (event -> IO ()) -> IO ()
toGtkCallback (ImpureEventHandler r :: widget -> EventHandlerReturn IO ret event
r) w :: widget
w f :: event -> IO ()
f =
    let OnlyEvent me = widget -> EventHandlerReturn IO ret event
r widget
w in IO event
me IO event -> (event -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= event -> IO ()
f

instance ToGtkCallback (IO Bool) Impure where
  toGtkCallback :: EventHandler (IO Bool) widget 'Impure event
-> widget -> (event -> IO ()) -> IO Bool
toGtkCallback (ImpureEventHandler r :: widget -> EventHandlerReturn IO ret event
r) w :: widget
w f :: event -> IO ()
f = do
    let ReturnAndEvent re = widget -> EventHandlerReturn IO ret event
r widget
w
    (r' :: Bool
r', e :: event
e) <- IO (Bool, event)
re
    event -> IO ()
f event
e
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
r'

instance ToGtkCallback y purity => ToGtkCallback (x -> y) purity where
  toGtkCallback :: EventHandler (x -> y) widget purity event
-> widget -> (event -> IO ()) -> x -> y
toGtkCallback (EventHandlerFunction cb :: a -> EventHandler b widget purity event
cb) f :: widget
f w :: event -> IO ()
w x :: x
x = EventHandler b widget purity event
-> widget -> (event -> IO ()) -> b
forall gtkCallback (purity :: Purity) widget event.
ToGtkCallback gtkCallback purity =>
EventHandler gtkCallback widget purity event
-> widget -> (event -> IO ()) -> gtkCallback
toGtkCallback (a -> EventHandler b widget purity event
cb x
a
x) widget
f event -> IO ()
w