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

{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedLabels       #-}
{-# LANGUAGE TypeFamilies           #-}

-- | Attribute lists on declarative objects, supporting the underlying
-- attributes from "Data.GI.Base.Attributes", along with CSS class lists, and
-- pure and impure event EventHandlers.

module GI.Gtk.Declarative.Attributes
  ( Attribute(..)
  , classes
  , ClassSet
  -- * Event Handling
  , on
  , onM
  -- * EventHandlers
  , EventHandler(..)
  )
where

import qualified Data.GI.Base.Attributes       as GI
import qualified Data.GI.Base.Signals          as GI
import           Data.HashSet                   ( HashSet )
import qualified Data.HashSet                  as HashSet
import qualified Data.Text                     as T
import           Data.Text                      ( Text )
import           Data.Typeable
import           GHC.TypeLits                   ( KnownSymbol
                                                , Symbol
                                                )
import qualified GI.Gtk                        as Gtk

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

-- * Attributes

-- | The attribute GADT represent a supported attribute for a declarative
-- widget. This extends the regular notion of GTK+ attributes to also include
-- event handling and CSS classes.
data Attribute widget event where
  -- | An attribute/value mapping for a declarative widget. The
  -- 'GI.AttrLabelProxy' is parameterized by 'attr', which represents the
  -- GTK-defined attribute name. The underlying GI object needs to support
  -- the /construct/, /get/, and /set/ operations for the given attribute.
  (:=)
    ::(GI.AttrOpAllowed 'GI.AttrConstruct info widget
      , GI.AttrOpAllowed 'GI.AttrSet info widget
      , GI.AttrGetC info widget attr getValue
      , GI.AttrSetTypeConstraint info setValue
      , KnownSymbol attr
      , Typeable attr
      , Eq setValue
      , Typeable setValue
      )
   => GI.AttrLabelProxy (attr :: Symbol) -> setValue -> Attribute widget event
  -- | Defines a set of CSS classes for the underlying widget's style context.
  -- Use the 'classes' function instead of this constructor directly.
  Classes
    ::Gtk.IsWidget widget
    => ClassSet
    -> Attribute widget event
  -- | Emit events using a pure event handler. Use the 'on' function, instead of this
  -- constructor directly.
  OnSignalPure
    ::( Gtk.GObject widget
       , GI.SignalInfo info
       , gtkCallback ~ GI.HaskellCallbackType info
       , ToGtkCallback gtkCallback Pure
       )
    => Gtk.SignalProxy widget info
    -> EventHandler gtkCallback widget Pure event
    -> Attribute widget event
  -- | Emit events using a pure event handler. Use the 'on' function, instead of this
  -- constructor directly.
  OnSignalImpure
    ::( Gtk.GObject widget
       , GI.SignalInfo info
       , gtkCallback ~ GI.HaskellCallbackType info
       , ToGtkCallback gtkCallback Impure
       )
    => Gtk.SignalProxy widget info
    -> EventHandler gtkCallback widget Impure event
    -> Attribute widget event

-- | A set of CSS classes.
type ClassSet = HashSet Text

-- | Attributes have a 'Functor' instance that maps events in all
-- event handler.
instance Functor (Attribute widget) where
  fmap :: (a -> b) -> Attribute widget a -> Attribute widget b
fmap f :: a -> b
f = \case
    attr :: AttrLabelProxy attr
attr := value :: setValue
value            -> AttrLabelProxy attr
attr AttrLabelProxy attr -> setValue -> Attribute widget b
forall info widget (attr :: Symbol) getValue setValue event.
(AttrOpAllowed 'AttrConstruct info widget,
 AttrOpAllowed 'AttrSet info widget,
 AttrGetC info widget attr getValue,
 AttrSetTypeConstraint info setValue, KnownSymbol attr,
 Typeable attr, Eq setValue, Typeable setValue) =>
AttrLabelProxy attr -> setValue -> Attribute widget event
:= setValue
value
    Classes cs :: ClassSet
cs               -> ClassSet -> Attribute widget b
forall widget event.
IsWidget widget =>
ClassSet -> Attribute widget event
Classes ClassSet
cs
    OnSignalPure   signal :: SignalProxy widget info
signal eh :: EventHandler gtkCallback widget 'Pure a
eh -> SignalProxy widget info
-> EventHandler gtkCallback widget 'Pure b -> Attribute widget b
forall widget info gtkCallback event.
(GObject widget, SignalInfo info,
 gtkCallback ~ HaskellCallbackType info,
 ToGtkCallback gtkCallback 'Pure) =>
SignalProxy widget info
-> EventHandler gtkCallback widget 'Pure event
-> Attribute widget event
OnSignalPure SignalProxy widget info
signal ((a -> b)
-> EventHandler gtkCallback widget 'Pure a
-> EventHandler gtkCallback widget 'Pure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f EventHandler gtkCallback widget 'Pure a
eh)
    OnSignalImpure signal :: SignalProxy widget info
signal eh :: EventHandler gtkCallback widget 'Impure a
eh -> SignalProxy widget info
-> EventHandler gtkCallback widget 'Impure b -> Attribute widget b
forall widget info gtkCallback event.
(GObject widget, SignalInfo info,
 gtkCallback ~ HaskellCallbackType info,
 ToGtkCallback gtkCallback 'Impure) =>
SignalProxy widget info
-> EventHandler gtkCallback widget 'Impure event
-> Attribute widget event
OnSignalImpure SignalProxy widget info
signal ((a -> b)
-> EventHandler gtkCallback widget 'Impure a
-> EventHandler gtkCallback widget 'Impure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f EventHandler gtkCallback widget 'Impure a
eh)

-- | Define the CSS classes for the underlying widget's style context. For these
-- classes to have any effect, this requires a 'Gtk.CssProvider' with CSS files
-- loaded, to be added to the GDK screen. You probably want to do this in your
-- entry point when setting up GTK.
classes :: Gtk.IsWidget widget => [T.Text] -> Attribute widget event
classes :: [Text] -> Attribute widget event
classes = ClassSet -> Attribute widget event
forall widget event.
IsWidget widget =>
ClassSet -> Attribute widget event
Classes (ClassSet -> Attribute widget event)
-> ([Text] -> ClassSet) -> [Text] -> Attribute widget event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> ClassSet
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList

-- | Emit events, using a pure event handler, by subcribing to the specified
-- signal.
on
  :: ( Gtk.GObject widget
     , GI.SignalInfo info
     , gtkCallback ~ GI.HaskellCallbackType info
     , ToGtkCallback gtkCallback Pure
     , ToEventHandler gtkCallback widget Pure
     , userEventHandler ~ UserEventHandler gtkCallback widget Pure event
     )
  => Gtk.SignalProxy widget info
  -> userEventHandler
  -> Attribute widget event
on :: SignalProxy widget info
-> userEventHandler -> Attribute widget event
on signal :: SignalProxy widget info
signal = SignalProxy widget info
-> EventHandler gtkCallback widget 'Pure event
-> Attribute widget event
forall widget info gtkCallback event.
(GObject widget, SignalInfo info,
 gtkCallback ~ HaskellCallbackType info,
 ToGtkCallback gtkCallback 'Pure) =>
SignalProxy widget info
-> EventHandler gtkCallback widget 'Pure event
-> Attribute widget event
OnSignalPure SignalProxy widget info
signal (EventHandler gtkCallback widget 'Pure event
 -> Attribute widget event)
-> (userEventHandler
    -> EventHandler gtkCallback widget 'Pure event)
-> userEventHandler
-> Attribute widget event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. userEventHandler -> EventHandler gtkCallback widget 'Pure event
forall gtkEventHandler widget (purity :: Purity) event.
ToEventHandler gtkEventHandler widget purity =>
UserEventHandler gtkEventHandler widget purity event
-> EventHandler gtkEventHandler widget purity event
toEventHandler

-- | Emit events, using an impure event handler receiving the 'widget' and returning
-- an 'IO' action of 'event', by subcribing to the specified signal.
onM
  :: ( Gtk.GObject widget
     , GI.SignalInfo info
     , gtkCallback ~ GI.HaskellCallbackType info
     , ToGtkCallback gtkCallback Impure
     , ToEventHandler gtkCallback widget Impure
     , userEventHandler ~ UserEventHandler gtkCallback widget Impure event
     )
  => Gtk.SignalProxy widget info
  -> userEventHandler
  -> Attribute widget event
onM :: SignalProxy widget info
-> userEventHandler -> Attribute widget event
onM signal :: SignalProxy widget info
signal = SignalProxy widget info
-> EventHandler gtkCallback widget 'Impure event
-> Attribute widget event
forall widget info gtkCallback event.
(GObject widget, SignalInfo info,
 gtkCallback ~ HaskellCallbackType info,
 ToGtkCallback gtkCallback 'Impure) =>
SignalProxy widget info
-> EventHandler gtkCallback widget 'Impure event
-> Attribute widget event
OnSignalImpure SignalProxy widget info
signal (EventHandler gtkCallback widget 'Impure event
 -> Attribute widget event)
-> (userEventHandler
    -> EventHandler gtkCallback widget 'Impure event)
-> userEventHandler
-> Attribute widget event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. userEventHandler -> EventHandler gtkCallback widget 'Impure event
forall gtkEventHandler widget (purity :: Purity) event.
ToEventHandler gtkEventHandler widget purity =>
UserEventHandler gtkEventHandler widget purity event
-> EventHandler gtkEventHandler widget purity event
toEventHandler