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

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
module GI.Gtk.Declarative.Attributes.Internal.EventHandler
  ( Purity(..)
  , EventHandlerReturn(..)
  , EventHandler(..)
  , UserEventHandler
  , ToEventHandler(..)
  )
where

import           Data.Functor.Identity

-- | A 'EventHandler' can be either pure or impure.
data Purity = Pure | Impure

-- | The two supported types of return values in user event handlers are encoded
-- by the 'EventHandlerReturn' type; either you can return only an 'event', or if
-- the underlying GTK+ callback needs to return a 'Bool', you return
-- a @(Bool, event)@ tuple.
data EventHandlerReturn m gtkReturn event where
  OnlyEvent ::m e -> EventHandlerReturn m () e
  ReturnAndEvent ::m (Bool, e) -> EventHandlerReturn m Bool e

instance Functor m => Functor (EventHandlerReturn m gtkEventHandler) where
  fmap :: (a -> b)
-> EventHandlerReturn m gtkEventHandler a
-> EventHandlerReturn m gtkEventHandler b
fmap f :: a -> b
f = \case
    OnlyEvent      e :: m a
e  -> m b -> EventHandlerReturn m () b
forall (m :: * -> *) e. m e -> EventHandlerReturn m () e
OnlyEvent ((a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f m a
e)
    ReturnAndEvent mr :: m (Bool, a)
mr -> m (Bool, b) -> EventHandlerReturn m Bool b
forall (m :: * -> *) e. m (Bool, e) -> EventHandlerReturn m Bool e
ReturnAndEvent (((Bool, a) -> (Bool, b)) -> m (Bool, a) -> m (Bool, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (Bool, a) -> (Bool, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (Bool, a)
mr)

-- | Encodes the user event handler in such a way that we can have
-- a 'Functor' instance for arity-polymorphic event handlers.
data EventHandler gtkEventHandler widget (purity :: Purity) event where
  PureEventHandler ::EventHandlerReturn Identity ret e -> EventHandler (IO ret) w Pure e
  ImpureEventHandler ::(w -> EventHandlerReturn IO ret e) -> EventHandler (IO ret) w Impure e
  EventHandlerFunction ::(a -> EventHandler b w p e) -> EventHandler (a -> b) w p e

instance Functor (EventHandler gtkEventHandler widget purity) where
  fmap :: (a -> b)
-> EventHandler gtkEventHandler widget purity a
-> EventHandler gtkEventHandler widget purity b
fmap f :: a -> b
f = \case
    PureEventHandler     r :: EventHandlerReturn Identity ret a
r  -> EventHandlerReturn Identity ret b
-> EventHandler (IO ret) widget 'Pure b
forall ret e w.
EventHandlerReturn Identity ret e
-> EventHandler (IO ret) w 'Pure e
PureEventHandler ((a -> b)
-> EventHandlerReturn Identity ret a
-> EventHandlerReturn Identity ret b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f EventHandlerReturn Identity ret a
r)
    ImpureEventHandler   r :: widget -> EventHandlerReturn IO ret a
r  -> (widget -> EventHandlerReturn IO ret b)
-> EventHandler (IO ret) widget 'Impure b
forall w ret e.
(w -> EventHandlerReturn IO ret e)
-> EventHandler (IO ret) w 'Impure e
ImpureEventHandler ((EventHandlerReturn IO ret a -> EventHandlerReturn IO ret b)
-> (widget -> EventHandlerReturn IO ret a)
-> widget
-> EventHandlerReturn IO ret b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b)
-> EventHandlerReturn IO ret a -> EventHandlerReturn IO ret b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) widget -> EventHandlerReturn IO ret a
r)
    EventHandlerFunction eh :: a -> EventHandler b widget purity a
eh -> (a -> EventHandler b widget purity b)
-> EventHandler (a -> b) widget purity b
forall a b w (p :: Purity) e.
(a -> EventHandler b w p e) -> EventHandler (a -> b) w p e
EventHandlerFunction (\a :: a
a -> (a -> b)
-> EventHandler b widget purity a -> EventHandler b widget purity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (a -> EventHandler b widget purity a
eh a
a))

-- | Convert from a GTK+ callback type to a user event handler type (the ones
-- you'd apply 'on' and 'onM' with) based on the given widget, purity, and event
-- types.
type family UserEventHandler gtkCallback widget (purity :: Purity) event where
  UserEventHandler (IO ())   widget Pure   event = event
  UserEventHandler (IO Bool) widget Pure   event = (Bool, event)
  UserEventHandler (IO ())   widget Impure event = widget -> IO event
  UserEventHandler (IO Bool) widget Impure event = widget -> IO (Bool, event)
  UserEventHandler (a -> b)  widget purity event = a -> UserEventHandler b widget purity event

-- | Internal class for converting user event handlers to encoded 'EventHandler' values.
class ToEventHandler gtkEventHandler widget purity where
  -- | Convert from a user event handler to an 'EventHandler'.
  toEventHandler
    :: UserEventHandler gtkEventHandler widget purity event
    -> EventHandler gtkEventHandler widget purity event

instance ToEventHandler (IO ()) widget Pure where
  toEventHandler :: UserEventHandler (IO ()) widget 'Pure event
-> EventHandler (IO ()) widget 'Pure event
toEventHandler = EventHandlerReturn Identity () event
-> EventHandler (IO ()) widget 'Pure event
forall ret e w.
EventHandlerReturn Identity ret e
-> EventHandler (IO ret) w 'Pure e
PureEventHandler (EventHandlerReturn Identity () event
 -> EventHandler (IO ()) widget 'Pure event)
-> (event -> EventHandlerReturn Identity () event)
-> event
-> EventHandler (IO ()) widget 'Pure event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity event -> EventHandlerReturn Identity () event
forall (m :: * -> *) e. m e -> EventHandlerReturn m () e
OnlyEvent (Identity event -> EventHandlerReturn Identity () event)
-> (event -> Identity event)
-> event
-> EventHandlerReturn Identity () event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. event -> Identity event
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToEventHandler (IO Bool) widget Pure where
  toEventHandler :: UserEventHandler (IO Bool) widget 'Pure event
-> EventHandler (IO Bool) widget 'Pure event
toEventHandler = EventHandlerReturn Identity Bool event
-> EventHandler (IO Bool) widget 'Pure event
forall ret e w.
EventHandlerReturn Identity ret e
-> EventHandler (IO ret) w 'Pure e
PureEventHandler (EventHandlerReturn Identity Bool event
 -> EventHandler (IO Bool) widget 'Pure event)
-> ((Bool, event) -> EventHandlerReturn Identity Bool event)
-> (Bool, event)
-> EventHandler (IO Bool) widget 'Pure event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Bool, event) -> EventHandlerReturn Identity Bool event
forall (m :: * -> *) e. m (Bool, e) -> EventHandlerReturn m Bool e
ReturnAndEvent (Identity (Bool, event) -> EventHandlerReturn Identity Bool event)
-> ((Bool, event) -> Identity (Bool, event))
-> (Bool, event)
-> EventHandlerReturn Identity Bool event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, event) -> Identity (Bool, event)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToEventHandler (IO ()) widget Impure where
  toEventHandler :: UserEventHandler (IO ()) widget 'Impure event
-> EventHandler (IO ()) widget 'Impure event
toEventHandler eh :: UserEventHandler (IO ()) widget 'Impure event
eh = (widget -> EventHandlerReturn IO () event)
-> EventHandler (IO ()) widget 'Impure event
forall w ret e.
(w -> EventHandlerReturn IO ret e)
-> EventHandler (IO ret) w 'Impure e
ImpureEventHandler (IO event -> EventHandlerReturn IO () event
forall (m :: * -> *) e. m e -> EventHandlerReturn m () e
OnlyEvent (IO event -> EventHandlerReturn IO () event)
-> (widget -> IO event) -> widget -> EventHandlerReturn IO () event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserEventHandler (IO ()) widget 'Impure event
widget -> IO event
eh)

instance ToEventHandler (IO Bool) widget Impure where
  toEventHandler :: UserEventHandler (IO Bool) widget 'Impure event
-> EventHandler (IO Bool) widget 'Impure event
toEventHandler eh :: UserEventHandler (IO Bool) widget 'Impure event
eh = (widget -> EventHandlerReturn IO Bool event)
-> EventHandler (IO Bool) widget 'Impure event
forall w ret e.
(w -> EventHandlerReturn IO ret e)
-> EventHandler (IO ret) w 'Impure e
ImpureEventHandler (IO (Bool, event) -> EventHandlerReturn IO Bool event
forall (m :: * -> *) e. m (Bool, e) -> EventHandlerReturn m Bool e
ReturnAndEvent (IO (Bool, event) -> EventHandlerReturn IO Bool event)
-> (widget -> IO (Bool, event))
-> widget
-> EventHandlerReturn IO Bool event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserEventHandler (IO Bool) widget 'Impure event
widget -> IO (Bool, event)
eh)

instance (ToEventHandler b widget purity) => ToEventHandler (a -> b) widget purity where
  toEventHandler :: UserEventHandler (a -> b) widget purity event
-> EventHandler (a -> b) widget purity event
toEventHandler f :: UserEventHandler (a -> b) widget purity event
f = (a -> EventHandler b widget purity event)
-> EventHandler (a -> b) widget purity event
forall a b w (p :: Purity) e.
(a -> EventHandler b w p e) -> EventHandler (a -> b) w p e
EventHandlerFunction (UserEventHandler b widget purity event
-> EventHandler b widget purity event
forall gtkEventHandler widget (purity :: Purity) event.
ToEventHandler gtkEventHandler widget purity =>
UserEventHandler gtkEventHandler widget purity event
-> EventHandler gtkEventHandler widget purity event
toEventHandler (UserEventHandler b widget purity event
 -> EventHandler b widget purity event)
-> (a -> UserEventHandler b widget purity event)
-> a
-> EventHandler b widget purity event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserEventHandler (a -> b) widget purity event
a -> UserEventHandler b widget purity event
f)