content: {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
  {-# LANGUAGE DataKinds             #-}
  {-# LANGUAGE FlexibleContexts      #-}
  {-# LANGUAGE FlexibleInstances     #-}
  {-# LANGUAGE GADTs                 #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedLabels      #-}
  {-# LANGUAGE ScopedTypeVariables   #-}
  {-# LANGUAGE TypeApplications      #-}
  {-# LANGUAGE TypeFamilies          #-}
  {-# LANGUAGE TypeOperators         #-}
  
  -- | A declarative representation of 'Gtk.Bin' in GTK.
  module GI.Gtk.Declarative.Bin
    ( Bin(..)
    , bin
    )
  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 /bin/ widget, i.e. a widget with exactly one
  -- child.
  data Bin widget event where
    Bin
      ::( Typeable widget
         , Gtk.IsContainer widget
         , Gtk.IsBin widget
         , Gtk.IsWidget widget
         )
      => (Gtk.ManagedPtr widget -> widget)
      -> Vector (Attribute widget event)
      -> Widget event
      -> Bin widget event
  
  instance Functor (Bin widget) where
    fmap f (Bin ctor attrs child) = Bin ctor (fmap f <$> attrs) (fmap f child)
  
  -- | Construct a /bin/ widget, i.e. a widget with exactly one child.
  bin
    :: ( Typeable widget
       , Gtk.IsContainer widget
       , Gtk.IsBin widget
       , Gtk.IsWidget widget
       , FromWidget (Bin widget) target
       )
    => (Gtk.ManagedPtr widget -> widget) -- ^ A bin widget constructor from the underlying gi-gtk library.
    -> Vector (Attribute widget event)   -- ^ List of 'Attribute's.
    -> Widget event                       -- ^ The bin's child widget
    -> target event                      -- ^ The target, whose type is decided by 'FromWidget'.
  bin ctor attrs = fromWidget . Bin ctor attrs
  
  --
  -- Patchable
  --
  
  instance (Gtk.IsBin parent) => Patchable (Bin parent) where
    create (Bin (ctor :: Gtk.ManagedPtr w -> w) attrs child) = do
      let collected = collectAttributes attrs
      widget' <- Gtk.new ctor (constructProperties collected)
      Gtk.widgetShow widget'
  
      sc <- Gtk.widgetGetStyleContext widget'
      updateClasses sc mempty (collectedClasses collected)
  
      childState  <- create child
      childWidget <- someStateWidget childState
      maybe (pure ()) Gtk.widgetDestroy =<< Gtk.binGetChild widget'
      Gtk.containerAdd widget' childWidget
      return
        (SomeState
          (StateTreeBin (StateTreeNode widget' sc collected ()) childState)
        )
  
    patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) (Bin _ _ oldChild) (Bin (ctor :: Gtk.ManagedPtr
        w2
      -> w2) newAttributes newChild)
      = case (st, eqT @w1 @w2) of
        (StateTreeBin top oldChildState, Just Refl) ->
          let
            oldCollected      = stateTreeCollectedAttributes top
            newCollected      = collectAttributes newAttributes
            oldCollectedProps = collectedProperties oldCollected
            newCollectedProps = collectedProperties newCollected
          in
            if oldCollectedProps `canBeModifiedTo` newCollectedProps
              then Modify $ do
                binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)
                updateProperties binWidget oldCollectedProps newCollectedProps
                updateClasses (stateTreeStyleContext top)
                              (collectedClasses oldCollected)
                              (collectedClasses newCollected)
  
                let top' = top { stateTreeCollectedAttributes = newCollected }
                case patch oldChildState oldChild newChild of
                  Modify  modify    -> SomeState . StateTreeBin top' <$> modify
                  Replace createNew -> do
                    Gtk.widgetDestroy =<< someStateWidget oldChildState
                    newChildState <- createNew
                    childWidget   <- someStateWidget newChildState
                    Gtk.widgetShow childWidget
                    maybe (pure ()) Gtk.widgetDestroy
                      =<< Gtk.binGetChild binWidget
                    Gtk.containerAdd binWidget childWidget
                    return (SomeState (StateTreeBin top' newChildState))
                  Keep -> return (SomeState st)
              else Replace (create (Bin ctor newAttributes newChild))
        _ -> Replace (create (Bin ctor newAttributes newChild))
  
  --
  -- EventSource
  --
  
  instance Gtk.IsBin parent => EventSource (Bin parent) where
    subscribe (Bin ctor props child) (SomeState st) cb = case st of
      StateTreeBin top childState -> do
        binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)
        handlers' <- foldMap (addSignalHandler cb binWidget) props
        (<> handlers') <$> subscribe child childState cb
      _ -> error "Cannot subscribe to Bin events with a non-bin state tree."
  
  instance a ~ b => FromWidget (Bin a) (Bin b) where
    fromWidget = id
  