{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | While you can instantiate 'Patchable' and 'EventSource' for your
-- own data types, it's a bit complicated. The 'CustomWidget' data
-- type takes care of some lower-level detail, so that you can focus
-- on the custom behavior of your widget. You still need to think
-- about and implement a patching function, but in an easier way.
module GI.Gtk.Declarative.CustomWidget
  ( CustomPatch(..)
  , CustomWidget(..)
  )
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.EventSource
import           GI.Gtk.Declarative.Patch
import           GI.Gtk.Declarative.State

-- | Similar to 'Patch', describing a possible action to perform on a
-- 'Gtk.Widget', decided by 'customPatch'.
data CustomPatch widget internalState
  = CustomReplace
  | CustomModify (widget -> IO internalState)
  | CustomKeep

-- | A custom widget specification, with all functions needed to
-- instantiate 'Patchable' and 'EventSource'. A custom widget:
--
-- * is based on a top 'widget'
-- * can use 'internalState' as a way of keeping an internal state
--   value threaded through updates, which is often useful for passing
--   references to child widgets used in a custom widget
-- * emits events of type 'event'
data CustomWidget widget params internalState event
  = CustomWidget
      { -- | The widget constructor
        CustomWidget widget params internalState event
-> ManagedPtr widget -> widget
customWidget :: Gtk.ManagedPtr widget -> widget,
        -- | Action that creates the initial widget
        CustomWidget widget params internalState event
-> params -> IO (widget, internalState)
customCreate :: params -> IO (widget, internalState),
        -- | Patch function, calculating a 'CustomPatch' based on the state,
        -- old custom data, and new custom data
        CustomWidget widget params internalState event
-> params
-> params
-> internalState
-> CustomPatch widget internalState
customPatch :: params -> params -> internalState -> CustomPatch widget internalState,
        -- | Action that creates an event subscription for the custom widget
        CustomWidget widget params internalState event
-> params
-> internalState
-> widget
-> (event -> IO ())
-> IO Subscription
customSubscribe :: params -> internalState -> widget -> (event -> IO ()) -> IO Subscription,
        -- | Declarative 'Attribute's for the custom widget (properties and
        -- classes are handled automatically in patching)
        CustomWidget widget params internalState event
-> Vector (Attribute widget event)
customAttributes :: Vector (Attribute widget event),
        -- | Parameters passed when constructing the declarative custom widget
        CustomWidget widget params internalState event -> params
customParams :: params
      }
  deriving (a
-> CustomWidget widget params internalState b
-> CustomWidget widget params internalState a
(a -> b)
-> CustomWidget widget params internalState a
-> CustomWidget widget params internalState b
(forall a b.
 (a -> b)
 -> CustomWidget widget params internalState a
 -> CustomWidget widget params internalState b)
-> (forall a b.
    a
    -> CustomWidget widget params internalState b
    -> CustomWidget widget params internalState a)
-> Functor (CustomWidget widget params internalState)
forall a b.
a
-> CustomWidget widget params internalState b
-> CustomWidget widget params internalState a
forall a b.
(a -> b)
-> CustomWidget widget params internalState a
-> CustomWidget widget params internalState b
forall widget params internalState a b.
a
-> CustomWidget widget params internalState b
-> CustomWidget widget params internalState a
forall widget params internalState a b.
(a -> b)
-> CustomWidget widget params internalState a
-> CustomWidget widget params internalState b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a
-> CustomWidget widget params internalState b
-> CustomWidget widget params internalState a
$c<$ :: forall widget params internalState a b.
a
-> CustomWidget widget params internalState b
-> CustomWidget widget params internalState a
fmap :: (a -> b)
-> CustomWidget widget params internalState a
-> CustomWidget widget params internalState b
$cfmap :: forall widget params internalState a b.
(a -> b)
-> CustomWidget widget params internalState a
-> CustomWidget widget params internalState b
Functor)

instance
  ( Typeable widget,
    Typeable internalState,
    Gtk.IsWidget widget
  ) =>
  Patchable (CustomWidget widget params internalState)
  where

  create :: CustomWidget widget params internalState e -> IO SomeState
create custom :: CustomWidget widget params internalState e
custom = do
    (widget :: widget
widget, internalState :: internalState
internalState) <- CustomWidget widget params internalState e
-> params -> IO (widget, internalState)
forall widget params internalState event.
CustomWidget widget params internalState event
-> params -> IO (widget, internalState)
customCreate CustomWidget widget params internalState e
custom (CustomWidget widget params internalState e -> params
forall widget params internalState event.
CustomWidget widget params internalState event -> params
customParams CustomWidget widget params internalState e
custom)
    widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow widget
widget
    let collected :: Collected widget e
collected = Vector (Attribute widget e) -> Collected widget e
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes (CustomWidget widget params internalState e
-> Vector (Attribute widget e)
forall widget params internalState event.
CustomWidget widget params internalState event
-> Vector (Attribute widget event)
customAttributes CustomWidget widget params internalState e
custom)
    widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
forall widget.
widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
updateProperties widget
widget CollectedProperties widget
forall a. Monoid a => a
mempty (Collected widget e -> CollectedProperties widget
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget e
collected)
    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 (f :: * -> *) a. Applicative f => a -> f a
pure
      (StateTree 'WidgetState widget Any e internalState -> 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 internalState
-> StateTree 'WidgetState widget Any e internalState
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> StateTree 'WidgetState widget child event customState
StateTreeWidget (widget
-> StyleContext
-> Collected widget e
-> internalState
-> StateTreeNode widget e internalState
forall widget event customState.
widget
-> StyleContext
-> Collected widget event
-> customState
-> StateTreeNode widget event customState
StateTreeNode widget
widget StyleContext
sc Collected widget e
collected internalState
internalState))
      )

  patch :: SomeState
-> CustomWidget widget params internalState e1
-> CustomWidget widget params internalState e2
-> Patch
patch (SomeState (StateTree stateType widget child event customState
stateTree :: StateTree st w e c cs)) old :: CustomWidget widget params internalState e1
old new :: CustomWidget widget params internalState e2
new =
    case ((Typeable customState, Typeable internalState) =>
Maybe (customState :~: internalState)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @cs @internalState, (Typeable widget, Typeable widget) => Maybe (widget :~: widget)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @widget @w) of
      (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 (StateTree stateType widget child event customState
-> StateTreeNode widget event customState
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState
-> StateTreeNode widget event customState
stateTreeNode StateTree stateType widget child event customState
stateTree)
          newCollected :: Collected widget e2
newCollected = Vector (Attribute widget e2) -> Collected widget e2
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes (CustomWidget widget params internalState e2
-> Vector (Attribute widget e2)
forall widget params internalState event.
CustomWidget widget params internalState event
-> Vector (Attribute widget event)
customAttributes CustomWidget widget params internalState e2
new)
          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
          canBeModified :: Bool
canBeModified = CollectedProperties widget
oldCollectedProps CollectedProperties widget -> CollectedProperties widget -> Bool
forall widget.
CollectedProperties widget -> CollectedProperties widget -> Bool
`canBeModifiedTo` CollectedProperties widget
CollectedProperties widget
newCollectedProps
        in
          case
            CustomWidget widget params internalState e2
-> params
-> params
-> internalState
-> CustomPatch widget internalState
forall widget params internalState event.
CustomWidget widget params internalState event
-> params
-> params
-> internalState
-> CustomPatch widget internalState
customPatch CustomWidget widget params internalState e2
new
                        (CustomWidget widget params internalState e1 -> params
forall widget params internalState event.
CustomWidget widget params internalState event -> params
customParams CustomWidget widget params internalState e1
old)
                        (CustomWidget widget params internalState e2 -> params
forall widget params internalState event.
CustomWidget widget params internalState event -> params
customParams CustomWidget widget params internalState e2
new)
                        (StateTreeNode widget event customState -> customState
forall widget event customState.
StateTreeNode widget event customState -> customState
stateTreeCustomState (StateTree stateType widget child event customState
-> StateTreeNode widget event customState
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState
-> StateTreeNode widget event customState
stateTreeNode StateTree stateType widget child event customState
stateTree))
          of
            CustomReplace -> IO SomeState -> Patch
Replace (CustomWidget widget params internalState e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create CustomWidget widget params internalState e2
new)
            p :: CustomPatch widget internalState
p
              | Bool
canBeModified -> IO SomeState -> Patch
Modify (IO SomeState -> Patch) -> IO SomeState -> Patch
forall a b. (a -> b) -> a -> b
$ do
                let widget' :: widget
widget' = StateTree stateType widget child event customState -> widget
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState -> widget
stateTreeNodeWidget StateTree stateType widget child event customState
stateTree
                widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
forall widget.
widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
updateProperties widget
widget' 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 (StateTree stateType widget child event customState
-> StateTreeNode widget event customState
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState
-> StateTreeNode widget event customState
stateTreeNode StateTree stateType widget child event customState
stateTree))
                  (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 node :: StateTreeNode widget event customState
node = StateTree stateType widget child event customState
-> StateTreeNode widget event customState
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState
-> StateTreeNode widget event customState
stateTreeNode StateTree stateType widget child event customState
stateTree
                internalState
internalState' <- case CustomPatch widget internalState
p of
                  CustomModify f :: widget -> IO internalState
f ->
                    widget -> IO internalState
f (widget -> IO internalState) -> IO widget -> IO internalState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ManagedPtr widget -> widget) -> widget -> IO widget
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo (CustomWidget widget params internalState e2
-> ManagedPtr widget -> widget
forall widget params internalState event.
CustomWidget widget params internalState event
-> ManagedPtr widget -> widget
customWidget CustomWidget widget params internalState e2
new) widget
widget'
                  CustomKeep    -> customState -> IO customState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateTreeNode widget event customState -> customState
forall widget event customState.
StateTreeNode widget event customState -> customState
stateTreeCustomState StateTreeNode widget event customState
node)
                  CustomReplace -> customState -> IO customState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateTreeNode widget event customState -> customState
forall widget event customState.
StateTreeNode widget event customState -> customState
stateTreeCustomState StateTreeNode widget event customState
node) -- already handled above
                SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return
                  (StateTree 'WidgetState widget Any e2 internalState -> 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 internalState
-> StateTree 'WidgetState widget Any e2 internalState
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> StateTree 'WidgetState widget child event customState
StateTreeWidget StateTreeNode widget event customState
node
                      { stateTreeCustomState :: internalState
stateTreeCustomState         = internalState
internalState'
                      , stateTreeCollectedAttributes :: Collected widget e2
stateTreeCollectedAttributes = Collected widget e2
Collected widget e2
newCollected
                      }
                    )
                  )
              | Bool
otherwise -> IO SomeState -> Patch
Replace (CustomWidget widget params internalState e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create CustomWidget widget params internalState e2
new)
      _ -> IO SomeState -> Patch
Replace (CustomWidget widget params internalState e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create CustomWidget widget params internalState e2
new)

instance
  (Typeable internalState, Gtk.GObject widget) =>
  EventSource (CustomWidget widget params internalState)
  where
  subscribe :: CustomWidget widget params internalState event
-> SomeState -> (event -> IO ()) -> IO Subscription
subscribe custom :: CustomWidget widget params internalState event
custom (SomeState (StateTree stateType widget child event customState
stateTree :: StateTree st w e c cs)) cb :: event -> IO ()
cb =
    case (Typeable customState, Typeable internalState) =>
Maybe (customState :~: internalState)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @cs @internalState of
      Just Refl -> do
        widget
w' <- (ManagedPtr widget -> widget) -> widget -> IO widget
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo (CustomWidget widget params internalState event
-> ManagedPtr widget -> widget
forall widget params internalState event.
CustomWidget widget params internalState event
-> ManagedPtr widget -> widget
customWidget CustomWidget widget params internalState event
custom)
                               (StateTree stateType widget child event customState -> widget
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState -> widget
stateTreeNodeWidget StateTree stateType widget child event customState
stateTree)
        CustomWidget widget params internalState event
-> params
-> internalState
-> widget
-> (event -> IO ())
-> IO Subscription
forall widget params internalState event.
CustomWidget widget params internalState event
-> params
-> internalState
-> widget
-> (event -> IO ())
-> IO Subscription
customSubscribe CustomWidget widget params internalState event
custom
                        (CustomWidget widget params internalState event -> params
forall widget params internalState event.
CustomWidget widget params internalState event -> params
customParams CustomWidget widget params internalState event
custom)
                        (StateTreeNode widget event customState -> customState
forall widget event customState.
StateTreeNode widget event customState -> customState
stateTreeCustomState (StateTree stateType widget child event customState
-> StateTreeNode widget event customState
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState
-> StateTreeNode widget event customState
stateTreeNode StateTree stateType widget child event customState
stateTree))
                        widget
w'
                        event -> IO ()
cb
      Nothing -> 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 ()))