{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

-- | A declarative representation of 'Gtk.Widget' in GTK without children.
module GI.Gtk.Declarative.SingleWidget
  ( SingleWidget
  , widget
  )
where

import           Data.Typeable
import           Data.Vector                    ( Vector )
import qualified GI.Gtk                        as Gtk

import           GI.Gtk.Declarative.Attributes
import           GI.Gtk.Declarative.Attributes.Collected
import           GI.Gtk.Declarative.Attributes.Internal
import           GI.Gtk.Declarative.EventSource
import           GI.Gtk.Declarative.Patch
import           GI.Gtk.Declarative.State
import           GI.Gtk.Declarative.Widget

-- | Declarative version of a /leaf/ widget, i.e. a widget without any children.
data SingleWidget widget event where
  SingleWidget
    ::(Typeable widget, Gtk.IsWidget widget, Functor (Attribute widget))
    => (Gtk.ManagedPtr widget -> widget)
    -> Vector (Attribute widget event)
    -> SingleWidget widget event

instance Functor (SingleWidget widget) where
  fmap :: (a -> b) -> SingleWidget widget a -> SingleWidget widget b
fmap f :: a -> b
f (SingleWidget ctor :: ManagedPtr widget -> widget
ctor attrs :: Vector (Attribute widget a)
attrs) = (ManagedPtr widget -> widget)
-> Vector (Attribute widget b) -> SingleWidget widget b
forall widget event.
(Typeable widget, IsWidget widget, Functor (Attribute widget)) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> SingleWidget widget event
SingleWidget ManagedPtr widget -> widget
ctor ((a -> b) -> Attribute widget a -> Attribute widget b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Attribute widget a -> Attribute widget b)
-> Vector (Attribute widget a) -> Vector (Attribute widget b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Attribute widget a)
attrs)

instance Patchable (SingleWidget widget) where
  create :: SingleWidget widget e -> IO SomeState
create = \case
    SingleWidget ctor :: ManagedPtr widget -> widget
ctor attrs :: Vector (Attribute widget e)
attrs -> do
      let collected :: Collected widget e
collected = Vector (Attribute widget e) -> Collected widget e
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes Vector (Attribute widget e)
attrs
      widget
widget' <- (ManagedPtr widget -> widget)
-> [AttrOp widget 'AttrConstruct] -> IO widget
forall a (tag :: AttrOpTag) (m :: * -> *).
(Constructible a tag, MonadIO m) =>
(ManagedPtr a -> a) -> [AttrOp a tag] -> m a
Gtk.new ManagedPtr widget -> widget
ctor (Collected widget e -> [AttrOp widget 'AttrConstruct]
forall widget event.
Collected widget event -> [AttrOp widget 'AttrConstruct]
constructProperties Collected widget e
collected)
      widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow widget
widget'
      StyleContext
sc <- widget -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext widget
widget'
      StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses StyleContext
sc ClassSet
forall a. Monoid a => a
mempty (Collected widget e -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected widget e
collected)
      SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return
        (StateTree 'WidgetState widget Any e () -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState (StateTreeNode widget e () -> StateTree 'WidgetState widget Any e ()
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> StateTree 'WidgetState widget child event customState
StateTreeWidget (widget
-> StyleContext
-> Collected widget e
-> ()
-> StateTreeNode widget e ()
forall widget event customState.
widget
-> StyleContext
-> Collected widget event
-> customState
-> StateTreeNode widget event customState
StateTreeNode widget
widget' StyleContext
sc Collected widget e
collected ())))
  patch :: SomeState
-> SingleWidget widget e1 -> SingleWidget widget e2 -> Patch
patch (SomeState (StateTree stateType widget child event customState
st :: StateTree stateType w child event cs)) (SingleWidget (ManagedPtr widget -> widget
_ :: Gtk.ManagedPtr
      w1
    -> w1) _) (SingleWidget (ManagedPtr widget -> widget
ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes :: Vector (Attribute widget e2)
newAttributes)
    = case (StateTree stateType widget child event customState
st, (Typeable widget, Typeable widget) => Maybe (widget :~: widget)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @w @w1, (Typeable widget, Typeable widget) => Maybe (widget :~: widget)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @w1 @w2) of
      (StateTreeWidget top :: StateTreeNode widget event customState
top, Just Refl, Just Refl) ->
        let
          oldCollected :: Collected widget event
oldCollected      = StateTreeNode widget event customState -> Collected widget event
forall widget event customState.
StateTreeNode widget event customState -> Collected widget event
stateTreeCollectedAttributes StateTreeNode widget event customState
top
          newCollected :: Collected widget e2
newCollected      = Vector (Attribute widget e2) -> Collected widget e2
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes Vector (Attribute widget e2)
newAttributes
          oldCollectedProps :: CollectedProperties widget
oldCollectedProps = Collected widget event -> CollectedProperties widget
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget event
oldCollected
          newCollectedProps :: CollectedProperties widget
newCollectedProps = Collected widget e2 -> CollectedProperties widget
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget e2
newCollected
        in
          if CollectedProperties widget
oldCollectedProps CollectedProperties widget -> CollectedProperties widget -> Bool
forall widget.
CollectedProperties widget -> CollectedProperties widget -> Bool
`canBeModifiedTo` CollectedProperties widget
CollectedProperties widget
newCollectedProps
            then IO SomeState -> Patch
Modify (IO SomeState -> Patch) -> IO SomeState -> Patch
forall a b. (a -> b) -> a -> b
$ do
              let w :: widget
w = StateTreeNode widget event customState -> widget
forall widget event customState.
StateTreeNode widget event customState -> widget
stateTreeWidget StateTreeNode widget event customState
top
              widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
forall widget.
widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
updateProperties widget
w CollectedProperties widget
oldCollectedProps CollectedProperties widget
CollectedProperties widget
newCollectedProps
              StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses (StateTreeNode widget event customState -> StyleContext
forall widget event customState.
StateTreeNode widget event customState -> StyleContext
stateTreeStyleContext StateTreeNode widget event customState
top)
                            (Collected widget event -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected widget event
oldCollected)
                            (Collected widget e2 -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected widget e2
newCollected)
              let top' :: StateTreeNode widget e2 customState
top' = StateTreeNode widget event customState
top { stateTreeCollectedAttributes :: Collected widget e2
stateTreeCollectedAttributes = Collected widget e2
Collected widget e2
newCollected }
              SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return
                (StateTree 'WidgetState widget Any e2 customState -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState
                  (StateTreeNode widget e2 customState
-> StateTree 'WidgetState widget Any e2 customState
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> StateTree 'WidgetState widget child event customState
StateTreeWidget StateTreeNode widget e2 customState
top'
                    { stateTreeCollectedAttributes :: Collected widget e2
stateTreeCollectedAttributes = Collected widget e2
Collected widget e2
newCollected
                    }
                  )
                )
            else IO SomeState -> Patch
Replace (SingleWidget widget e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create ((ManagedPtr widget -> widget)
-> Vector (Attribute widget e2) -> SingleWidget widget e2
forall widget event.
(Typeable widget, IsWidget widget, Functor (Attribute widget)) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> SingleWidget widget event
SingleWidget ManagedPtr widget -> widget
ctor Vector (Attribute widget e2)
newAttributes))
      _ -> IO SomeState -> Patch
Replace (SingleWidget widget e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create ((ManagedPtr widget -> widget)
-> Vector (Attribute widget e2) -> SingleWidget widget e2
forall widget event.
(Typeable widget, IsWidget widget, Functor (Attribute widget)) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> SingleWidget widget event
SingleWidget ManagedPtr widget -> widget
ctor Vector (Attribute widget e2)
newAttributes))

instance EventSource (SingleWidget widget) where
  subscribe :: SingleWidget widget event
-> SomeState -> (event -> IO ()) -> IO Subscription
subscribe (SingleWidget (ManagedPtr widget -> widget
_ :: Gtk.ManagedPtr w1 -> w1) props :: Vector (Attribute widget event)
props) (SomeState (StateTree stateType widget child event customState
st :: StateTree
      stateType
      w2
      child
      event
      cs)) cb :: event -> IO ()
cb
    = case (StateTree stateType widget child event customState
st, (Typeable widget, Typeable widget) => Maybe (widget :~: widget)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @w1 @w2) of
      (StateTreeWidget top :: StateTreeNode widget event customState
top, Just Refl) ->
        (Attribute widget event -> IO Subscription)
-> Vector (Attribute widget event) -> IO Subscription
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((event -> IO ())
-> widget -> Attribute widget event -> IO Subscription
forall widget (m :: * -> *) event.
(IsWidget widget, MonadIO m) =>
(event -> IO ())
-> widget -> Attribute widget event -> m Subscription
addSignalHandler event -> IO ()
cb (StateTreeNode widget event customState -> widget
forall widget event customState.
StateTreeNode widget event customState -> widget
stateTreeWidget StateTreeNode widget event customState
top)) Vector (Attribute widget event)
Vector (Attribute widget event)
props
      _ -> Subscription -> IO Subscription
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Subscription
fromCancellation (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

-- instance (Typeable widget, Functor (SingleWidget widget))
--   => FromWidget (SingleWidget widget) Widget where
--   fromWidget = Widget

-- | Construct a /leaf/ widget, i.e. one without any children.
widget
  :: ( Typeable widget
     , Gtk.IsWidget widget
     , FromWidget (SingleWidget widget) target
     )
  => (Gtk.ManagedPtr widget -> widget) -- ^ A widget constructor from the underlying gi-gtk library.
  -> Vector (Attribute widget event)   -- ^ List of 'Attribute's.
  -> target event                      -- ^ The target, whose type is decided by 'FromWidget'.
widget :: (ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> target event
widget ctor :: ManagedPtr widget -> widget
ctor = SingleWidget widget event -> target event
forall (widget :: * -> *) (target :: * -> *) event.
FromWidget widget target =>
widget event -> target event
fromWidget (SingleWidget widget event -> target event)
-> (Vector (Attribute widget event) -> SingleWidget widget event)
-> Vector (Attribute widget event)
-> target event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> SingleWidget widget event
forall widget event.
(Typeable widget, IsWidget widget, Functor (Attribute widget)) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> SingleWidget widget event
SingleWidget ManagedPtr widget -> widget
ctor