{-# 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 :: (a -> b) -> Bin widget a -> Bin widget b
fmap f :: a -> b
f (Bin ctor :: ManagedPtr widget -> widget
ctor attrs :: Vector (Attribute widget a)
attrs child :: Widget a
child) = (ManagedPtr widget -> widget)
-> Vector (Attribute widget b) -> Widget b -> Bin widget b
forall widget event.
(Typeable widget, IsContainer widget, IsBin widget,
 IsWidget widget) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> Widget event
-> Bin widget event
Bin ManagedPtr widget -> widget
ctor ((a -> b) -> Attribute widget a -> Attribute widget b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Attribute widget a -> Attribute widget b)
-> Vector (Attribute widget a) -> Vector (Attribute widget b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Attribute widget a)
attrs) ((a -> b) -> Widget a -> Widget b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Widget a
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 :: (ManagedPtr widget -> widget)
-> Vector (Attribute widget event) -> Widget event -> target event
bin ctor :: ManagedPtr widget -> widget
ctor attrs :: Vector (Attribute widget event)
attrs = Bin widget event -> target event
forall (widget :: * -> *) (target :: * -> *) event.
FromWidget widget target =>
widget event -> target event
fromWidget (Bin widget event -> target event)
-> (Widget event -> Bin widget event)
-> Widget event
-> target event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> Widget event
-> Bin widget event
forall widget event.
(Typeable widget, IsContainer widget, IsBin widget,
 IsWidget widget) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> Widget event
-> Bin widget event
Bin ManagedPtr widget -> widget
ctor Vector (Attribute widget event)
attrs

--
-- Patchable
--

instance (Gtk.IsBin parent) => Patchable (Bin parent) where
  create :: Bin parent e -> IO SomeState
create (Bin (ManagedPtr parent -> parent
ctor :: Gtk.ManagedPtr w -> w) attrs :: Vector (Attribute parent e)
attrs child :: Widget e
child) = do
    let collected :: Collected parent e
collected = Vector (Attribute parent e) -> Collected parent e
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes Vector (Attribute parent e)
attrs
    parent
widget' <- (ManagedPtr parent -> parent)
-> [AttrOp parent 'AttrConstruct] -> IO parent
forall a (tag :: AttrOpTag) (m :: * -> *).
(Constructible a tag, MonadIO m) =>
(ManagedPtr a -> a) -> [AttrOp a tag] -> m a
Gtk.new ManagedPtr parent -> parent
ctor (Collected parent e -> [AttrOp parent 'AttrConstruct]
forall widget event.
Collected widget event -> [AttrOp widget 'AttrConstruct]
constructProperties Collected parent e
collected)
    parent -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow parent
widget'

    StyleContext
sc <- parent -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext parent
widget'
    StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses StyleContext
sc ClassSet
forall a. Monoid a => a
mempty (Collected parent e -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected parent e
collected)

    SomeState
childState  <- Widget e -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create Widget e
child
    Widget
childWidget <- SomeState -> IO Widget
someStateWidget SomeState
childState
    IO () -> (Widget -> IO ()) -> Maybe Widget -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (Maybe Widget -> IO ()) -> IO (Maybe Widget) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< parent -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsBin a) =>
a -> m (Maybe Widget)
Gtk.binGetChild parent
widget'
    parent -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd parent
widget' Widget
childWidget
    SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return
      (StateTree 'BinState parent Any e () -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState
        (StateTreeNode parent e ()
-> SomeState -> StateTree 'BinState parent Any e ()
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> SomeState -> StateTree 'BinState widget child event customState
StateTreeBin (parent
-> StyleContext
-> Collected parent e
-> ()
-> StateTreeNode parent e ()
forall widget event customState.
widget
-> StyleContext
-> Collected widget event
-> customState
-> StateTreeNode widget event customState
StateTreeNode parent
widget' StyleContext
sc Collected parent e
collected ()) SomeState
childState)
      )

  patch :: SomeState -> Bin parent e1 -> Bin parent e2 -> Patch
patch (SomeState (StateTree stateType widget child event customState
st :: StateTree stateType w1 c1 e1 cs)) (Bin _ _ oldChild :: Widget e1
oldChild) (Bin (ManagedPtr parent -> parent
ctor :: Gtk.ManagedPtr
      w2
    -> w2) newAttributes :: Vector (Attribute parent e2)
newAttributes newChild :: Widget e2
newChild)
    = case (StateTree stateType widget child event customState
st, (Typeable widget, Typeable parent) => Maybe (widget :~: parent)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @w1 @w2) of
      (StateTreeBin top :: StateTreeNode widget event customState
top oldChildState :: SomeState
oldChildState, 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 StateTreeNode widget event customState
top
          newCollected :: Collected parent e2
newCollected      = Vector (Attribute parent e2) -> Collected parent e2
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes Vector (Attribute parent e2)
newAttributes
          oldCollectedProps :: CollectedProperties widget
oldCollectedProps = Collected widget event -> CollectedProperties widget
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected widget event
oldCollected
          newCollectedProps :: CollectedProperties parent
newCollectedProps = Collected parent e2 -> CollectedProperties parent
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected parent e2
newCollected
        in
          if CollectedProperties widget
oldCollectedProps CollectedProperties widget -> CollectedProperties widget -> Bool
forall widget.
CollectedProperties widget -> CollectedProperties widget -> Bool
`canBeModifiedTo` CollectedProperties parent
CollectedProperties widget
newCollectedProps
            then IO SomeState -> Patch
Modify (IO SomeState -> Patch) -> IO SomeState -> Patch
forall a b. (a -> b) -> a -> b
$ do
              parent
binWidget <- (ManagedPtr parent -> parent) -> widget -> IO parent
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo ManagedPtr parent -> parent
ctor (StateTreeNode widget event customState -> widget
forall widget event customState.
StateTreeNode widget event customState -> widget
stateTreeWidget StateTreeNode widget event customState
top)
              parent
-> CollectedProperties parent
-> CollectedProperties parent
-> IO ()
forall widget.
widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
updateProperties parent
binWidget CollectedProperties parent
CollectedProperties widget
oldCollectedProps CollectedProperties parent
newCollectedProps
              StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses (StateTreeNode widget event customState -> StyleContext
forall widget event customState.
StateTreeNode widget event customState -> StyleContext
stateTreeStyleContext StateTreeNode widget event customState
top)
                            (Collected widget event -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected widget event
oldCollected)
                            (Collected parent e2 -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected parent e2
newCollected)

              let top' :: StateTreeNode widget e2 customState
top' = StateTreeNode widget event customState
top { stateTreeCollectedAttributes :: Collected widget e2
stateTreeCollectedAttributes = Collected parent e2
Collected widget e2
newCollected }
              case SomeState -> Widget e1 -> Widget e2 -> Patch
forall (widget :: * -> *) e1 e2.
Patchable widget =>
SomeState -> widget e1 -> widget e2 -> Patch
patch SomeState
oldChildState Widget e1
oldChild Widget e2
newChild of
                Modify  modify :: IO SomeState
modify    -> StateTree 'BinState widget Any e2 customState -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState (StateTree 'BinState widget Any e2 customState -> SomeState)
-> (SomeState -> StateTree 'BinState widget Any e2 customState)
-> SomeState
-> SomeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateTreeNode widget e2 customState
-> SomeState -> StateTree 'BinState widget Any e2 customState
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> SomeState -> StateTree 'BinState widget child event customState
StateTreeBin StateTreeNode widget e2 customState
top' (SomeState -> SomeState) -> IO SomeState -> IO SomeState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SomeState
modify
                Replace createNew :: IO SomeState
createNew -> do
                  Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
oldChildState
                  SomeState
newChildState <- IO SomeState
createNew
                  Widget
childWidget   <- SomeState -> IO Widget
someStateWidget SomeState
newChildState
                  Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Widget
childWidget
                  IO () -> (Widget -> IO ()) -> Maybe Widget -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy
                    (Maybe Widget -> IO ()) -> IO (Maybe Widget) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< parent -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsBin a) =>
a -> m (Maybe Widget)
Gtk.binGetChild parent
binWidget
                  parent -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd parent
binWidget Widget
childWidget
                  SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return (StateTree 'BinState widget Any e2 customState -> 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 customState
-> SomeState -> StateTree 'BinState widget Any e2 customState
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> SomeState -> StateTree 'BinState widget child event customState
StateTreeBin StateTreeNode widget e2 customState
top' SomeState
newChildState))
                Keep -> SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return (StateTree stateType widget child event customState -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState StateTree stateType widget child event customState
st)
            else IO SomeState -> Patch
Replace (Bin parent e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create ((ManagedPtr parent -> parent)
-> Vector (Attribute parent e2) -> Widget e2 -> Bin parent e2
forall widget event.
(Typeable widget, IsContainer widget, IsBin widget,
 IsWidget widget) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> Widget event
-> Bin widget event
Bin ManagedPtr parent -> parent
ctor Vector (Attribute parent e2)
newAttributes Widget e2
newChild))
      _ -> IO SomeState -> Patch
Replace (Bin parent e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create ((ManagedPtr parent -> parent)
-> Vector (Attribute parent e2) -> Widget e2 -> Bin parent e2
forall widget event.
(Typeable widget, IsContainer widget, IsBin widget,
 IsWidget widget) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> Widget event
-> Bin widget event
Bin ManagedPtr parent -> parent
ctor Vector (Attribute parent e2)
newAttributes Widget e2
newChild))

--
-- EventSource
--

instance Gtk.IsBin parent => EventSource (Bin parent) where
  subscribe :: Bin parent event
-> SomeState -> (event -> IO ()) -> IO Subscription
subscribe (Bin ctor :: ManagedPtr parent -> parent
ctor props :: Vector (Attribute parent event)
props child :: Widget event
child) (SomeState st :: StateTree stateType widget child event customState
st) cb :: event -> IO ()
cb = case StateTree stateType widget child event customState
st of
    StateTreeBin top :: StateTreeNode widget event customState
top childState :: SomeState
childState -> do
      parent
binWidget <- (ManagedPtr parent -> parent) -> widget -> IO parent
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo ManagedPtr parent -> parent
ctor (StateTreeNode widget event customState -> widget
forall widget event customState.
StateTreeNode widget event customState -> widget
stateTreeWidget StateTreeNode widget event customState
top)
      Subscription
handlers' <- (Attribute parent event -> IO Subscription)
-> Vector (Attribute parent event) -> IO Subscription
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((event -> IO ())
-> parent -> Attribute parent event -> IO Subscription
forall widget (m :: * -> *) event.
(IsWidget widget, MonadIO m) =>
(event -> IO ())
-> widget -> Attribute widget event -> m Subscription
addSignalHandler event -> IO ()
cb parent
binWidget) Vector (Attribute parent event)
props
      (Subscription -> Subscription -> Subscription
forall a. Semigroup a => a -> a -> a
<> Subscription
handlers') (Subscription -> Subscription)
-> IO Subscription -> IO Subscription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Widget event -> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe Widget event
child SomeState
childState event -> IO ()
cb
    _ -> [Char] -> IO Subscription
forall a. HasCallStack => [Char] -> a
error "Cannot subscribe to Bin events with a non-bin state tree."

instance a ~ b => FromWidget (Bin a) (Bin b) where
  fromWidget :: Bin a event -> Bin b event
fromWidget = Bin a event -> Bin b event
forall a. a -> a
id