{-# 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
  :: ( Patchable (Bin widget)
     , Typeable widget
     , Typeable event
     , 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 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)

    mapM_ (applyAfterCreated widget') attrs

    childState <- create child
    childWidget <- someStateWidget childState
    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) ->
        Modify $ do
          binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)
          let oldCollected = stateTreeCollectedAttributes top
              newCollected = collectAttributes newAttributes
          updateProperties binWidget (collectedProperties oldCollected) (collectedProperties newCollected)
          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
              Gtk.containerAdd binWidget childWidget
              return (SomeState (StateTreeBin top' newChildState))
            Keep -> return (SomeState st)
      _ -> 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