Container.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

-- | Implementations for common "Gtk.Container".
module GI.Gtk.Declarative.Container
  ( Container
  , container
  , Children
  , ToChildren(..)
  )
where

import           Control.Monad                  ( forM )
import           Data.Typeable
import           Data.Vector                    ( Vector )
import qualified Data.Vector                   as 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.Container.Class
import           GI.Gtk.Declarative.Container.Patch
import           GI.Gtk.Declarative.EventSource
import           GI.Gtk.Declarative.Patch
import           GI.Gtk.Declarative.State
import           GI.Gtk.Declarative.Widget

-- | Declarative version of a /container/ widget, i.e. a widget with zero
-- or more child widgets. The type of 'children' is parameterized, and differs
-- across the supported container widgets, as some containers require specific
-- types of child widgets. These type relations are decided by 'IsContainer',
-- and instances can found in "GI.Gtk.Declarative.Container.Patch".
data Container widget children event where
  Container ::( Typeable widget,
      Gtk.IsWidget widget,
      Gtk.IsContainer widget,
      Functor children
    ) =>
    (Gtk.ManagedPtr widget -> widget) ->
    Vector (Attribute widget event) ->
    children event ->
    Container widget children event

instance Functor (Container widget children) where
  fmap f (Container ctor attrs children) =
    Container ctor (fmap f <$> attrs) (fmap f children)

-- | Construct a /container/ widget, i.e. a widget with zero or more children.
container
  :: ( Typeable widget
     , Functor child
     , Gtk.IsWidget widget
     , Gtk.IsContainer widget
     , FromWidget (Container widget (Children child)) target
     , ToChildren widget parent child
     )
  => 
  -- | A container widget constructor from the underlying gi-gtk library.
     (Gtk.ManagedPtr widget -> widget)
  ->
  -- | 'Attribute's.
     Vector (Attribute widget event)
  ->
  -- | The container's 'child' widgets, in a 'MarkupOf' builder.
     parent (child event)
  ->
  -- | The target, whose type is decided by 'FromWidget'.
     target event
container ctor attrs = fromWidget . Container ctor attrs . toChildren ctor

--
-- Patchable
--

instance
  (Patchable child, Typeable child, IsContainer container child) =>
  Patchable (Container container (Children child))
  where

  create (Container ctor attrs children) = do
    let collected = collectAttributes attrs
    widget' <- Gtk.new ctor (constructProperties collected)
    Gtk.widgetShow widget'
    sc <- Gtk.widgetGetStyleContext widget'
    updateClasses sc mempty (collectedClasses collected)
    childStates <- forM (unChildren children) $ \child -> do
      childState <- create child
      appendChild widget' child =<< someStateWidget childState
      return childState
    return
      (SomeState
        (StateTreeContainer (StateTreeNode widget' sc collected ()) childStates)
      )

  patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) (Container _ _ oldChildren) new@(Container (ctor :: Gtk.ManagedPtr
      w2
    -> w2) newAttributes (newChildren :: Children c2 e2))
    = case (st, eqT @w1 @w2) of
      (StateTreeContainer top childStates, Just Refl) ->
        let oldCollected      = stateTreeCollectedAttributes top
            newCollected      = collectAttributes newAttributes
            oldCollectedProps = collectedProperties oldCollected
            newCollectedProps = collectedProperties newCollected
        in  if oldCollectedProps `canBeModifiedTo` newCollectedProps
              then Modify $ do
                containerWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)
                updateProperties containerWidget
                                 oldCollectedProps
                                 newCollectedProps
                updateClasses (stateTreeStyleContext top)
                              (collectedClasses oldCollected)
                              (collectedClasses newCollected)
                let top' = top { stateTreeCollectedAttributes = newCollected }
                SomeState <$> patchInContainer
                  (StateTreeContainer top' childStates)
                  containerWidget
                  (unChildren oldChildren)
                  (unChildren newChildren)
              else Replace (create new)
      _ -> Replace (create new)

--
-- EventSource
--

instance
  EventSource child =>
  EventSource (Container widget (Children child))
  where
  subscribe (Container ctor props children) (SomeState st) cb = case st of
    StateTreeContainer top childStates -> do
      parentWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)
      handlers' <- foldMap (addSignalHandler cb parentWidget) props
      subs <- flip foldMap (Vector.zip (unChildren children) childStates)
        $ \(c, childState) -> subscribe c childState cb
      return (handlers' <> subs)
    _ ->
      error
        "Warning: Cannot subscribe to Container events with a non-container state tree."

--
-- FromWidget
--

instance
  ( Typeable widget,
    Typeable children,
    Patchable (Container widget children),
    EventSource (Container widget children)
  ) =>
  FromWidget (Container widget children) Widget
  where
  fromWidget = Widget

instance a ~ b => FromWidget (Container a children) (Container b children) where
  fromWidget = id