CustomWidget.hs

{-# 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 :: Gtk.ManagedPtr widget -> widget,
        -- | Action that creates the initial widget
        customCreate :: params -> IO (widget, internalState),
        -- | Patch function, calculating a 'CustomPatch' based on the state,
        -- old custom data, and new custom data
        customPatch :: params -> params -> internalState -> CustomPatch widget internalState,
        -- | Action that creates an event subscription for the custom widget
        customSubscribe :: params -> internalState -> widget -> (event -> IO ()) -> IO Subscription,
        -- | Declarative 'Attribute's for the custom widget (properties and
        -- classes are handled automatically in patching)
        customAttributes :: Vector (Attribute widget event),
        -- | Parameters passed when constructing the declarative custom widget
        customParams :: params
      }
  deriving (Functor)

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

  create custom = do
    (widget, internalState) <- customCreate custom (customParams custom)
    Gtk.widgetShow widget
    let collected = collectAttributes (customAttributes custom)
    updateProperties widget mempty (collectedProperties collected)
    sc <- Gtk.widgetGetStyleContext widget
    updateClasses sc mempty (collectedClasses collected)
    pure
      (SomeState
        (StateTreeWidget (StateTreeNode widget sc collected internalState))
      )

  patch (SomeState (stateTree :: StateTree st w e c cs)) old new =
    case (eqT @cs @internalState, eqT @widget @w) of
      (Just Refl, Just Refl) ->
        let
          oldCollected = stateTreeCollectedAttributes (stateTreeNode stateTree)
          newCollected = collectAttributes (customAttributes new)
          oldCollectedProps = collectedProperties oldCollected
          newCollectedProps = collectedProperties newCollected
          canBeModified = oldCollectedProps `canBeModifiedTo` newCollectedProps
        in
          case
            customPatch new
                        (customParams old)
                        (customParams new)
                        (stateTreeCustomState (stateTreeNode stateTree))
          of
            CustomReplace -> Replace (create new)
            p
              | canBeModified -> Modify $ do
                let widget' = stateTreeNodeWidget stateTree
                updateProperties widget' oldCollectedProps newCollectedProps
                updateClasses
                  (stateTreeStyleContext (stateTreeNode stateTree))
                  (collectedClasses oldCollected)
                  (collectedClasses newCollected)
                let node = stateTreeNode stateTree
                internalState' <- case p of
                  CustomModify f ->
                    f =<< Gtk.unsafeCastTo (customWidget new) widget'
                  CustomKeep    -> pure (stateTreeCustomState node)
                  CustomReplace -> pure (stateTreeCustomState node) -- already handled above
                return
                  (SomeState
                    (StateTreeWidget node
                      { stateTreeCustomState         = internalState'
                      , stateTreeCollectedAttributes = newCollected
                      }
                    )
                  )
              | otherwise -> Replace (create new)
      _ -> Replace (create new)

instance
  (Typeable internalState, Gtk.GObject widget) =>
  EventSource (CustomWidget widget params internalState)
  where
  subscribe custom (SomeState (stateTree :: StateTree st w e c cs)) cb =
    case eqT @cs @internalState of
      Just Refl -> do
        w' <- Gtk.unsafeCastTo (customWidget custom)
                               (stateTreeNodeWidget stateTree)
        customSubscribe custom
                        (customParams custom)
                        (stateTreeCustomState (stateTreeNode stateTree))
                        w'
                        cb
      Nothing -> pure (fromCancellation (pure ()))