EventHandler.hs

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

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# 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 f = \case
    OnlyEvent e -> OnlyEvent (fmap f e)
    ReturnAndEvent mr -> ReturnAndEvent (fmap (fmap f) 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 f = \case
    PureEventHandler r -> PureEventHandler (fmap f r)
    ImpureEventHandler r -> ImpureEventHandler (fmap (fmap f) r)
    EventHandlerFunction eh -> EventHandlerFunction (\a -> fmap f (eh 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 = PureEventHandler . OnlyEvent . pure

instance ToEventHandler (IO Bool) widget Pure where
  toEventHandler = PureEventHandler . ReturnAndEvent . pure

instance ToEventHandler (IO ()) widget Impure where
  toEventHandler eh = ImpureEventHandler (OnlyEvent . eh)

instance ToEventHandler (IO Bool) widget Impure where
  toEventHandler eh = ImpureEventHandler (ReturnAndEvent . eh)

instance (ToEventHandler b widget purity) => ToEventHandler (a -> b) widget purity where
  toEventHandler f = EventHandlerFunction (toEventHandler . f)