{-# 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 :: (a -> b)
-> Container widget children a -> Container widget children b
fmap f :: a -> b
f (Container ctor :: ManagedPtr widget -> widget
ctor attrs :: Vector (Attribute widget a)
attrs children :: children a
children) =
    (ManagedPtr widget -> widget)
-> Vector (Attribute widget b)
-> children b
-> Container widget children b
forall widget (children :: * -> *) event.
(Typeable widget, IsWidget widget, IsContainer widget,
 Functor children) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> children event
-> Container widget children event
Container 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) -> children a -> children b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f children a
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 :: (ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> parent (child event)
-> target event
container ctor :: ManagedPtr widget -> widget
ctor attrs :: Vector (Attribute widget event)
attrs = Container widget (Children child) event -> target event
forall (widget :: * -> *) (target :: * -> *) event.
FromWidget widget target =>
widget event -> target event
fromWidget (Container widget (Children child) event -> target event)
-> (parent (child event)
    -> Container widget (Children child) event)
-> parent (child event)
-> target event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> Children child event
-> Container widget (Children child) event
forall widget (children :: * -> *) event.
(Typeable widget, IsWidget widget, IsContainer widget,
 Functor children) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> children event
-> Container widget children event
Container ManagedPtr widget -> widget
ctor Vector (Attribute widget event)
attrs (Children child event -> Container widget (Children child) event)
-> (parent (child event) -> Children child event)
-> parent (child event)
-> Container widget (Children child) event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ManagedPtr widget -> widget)
-> parent (child event) -> Children child event
forall widget (parent :: * -> *) (child :: * -> *) event.
ToChildren widget parent child =>
(ManagedPtr widget -> widget)
-> parent (child event) -> Children child event
toChildren ManagedPtr widget -> widget
ctor

--
-- Patchable
--

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

  create :: Container container (Children child) e -> IO SomeState
create (Container ctor :: ManagedPtr container -> container
ctor attrs :: Vector (Attribute container e)
attrs children :: Children child e
children) = do
    let collected :: Collected container e
collected = Vector (Attribute container e) -> Collected container e
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes Vector (Attribute container e)
attrs
    container
widget' <- (ManagedPtr container -> container)
-> [AttrOp container 'AttrConstruct] -> IO container
forall a (tag :: AttrOpTag) (m :: * -> *).
(Constructible a tag, MonadIO m) =>
(ManagedPtr a -> a) -> [AttrOp a tag] -> m a
Gtk.new ManagedPtr container -> container
ctor (Collected container e -> [AttrOp container 'AttrConstruct]
forall widget event.
Collected widget event -> [AttrOp widget 'AttrConstruct]
constructProperties Collected container e
collected)
    container -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow container
widget'
    StyleContext
sc <- container -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext container
widget'
    StyleContext -> ClassSet -> ClassSet -> IO ()
updateClasses StyleContext
sc ClassSet
forall a. Monoid a => a
mempty (Collected container e -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected container e
collected)
    Vector SomeState
childStates <- Vector (child e)
-> (child e -> IO SomeState) -> IO (Vector SomeState)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Children child e -> Vector (child e)
forall (child :: * -> *) event.
Children child event -> Vector (child event)
unChildren Children child e
children) ((child e -> IO SomeState) -> IO (Vector SomeState))
-> (child e -> IO SomeState) -> IO (Vector SomeState)
forall a b. (a -> b) -> a -> b
$ \child :: child e
child -> do
      SomeState
childState <- child e -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create child e
child
      container -> child e -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Widget -> IO ()
appendChild container
widget' child e
child (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
childState
      SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return SomeState
childState
    SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return
      (StateTree 'ContainerState container child e () -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState
        (StateTreeNode container e ()
-> Vector SomeState
-> StateTree 'ContainerState container child e ()
forall widget (child :: * -> *) event customState.
(IsContainer widget, IsContainer widget child) =>
StateTreeNode widget event customState
-> Vector SomeState
-> StateTree 'ContainerState widget child event customState
StateTreeContainer (container
-> StyleContext
-> Collected container e
-> ()
-> StateTreeNode container e ()
forall widget event customState.
widget
-> StyleContext
-> Collected widget event
-> customState
-> StateTreeNode widget event customState
StateTreeNode container
widget' StyleContext
sc Collected container e
collected ()) Vector SomeState
childStates)
      )

  patch :: SomeState
-> Container container (Children child) e1
-> Container container (Children child) e2
-> Patch
patch (SomeState (StateTree stateType widget child event customState
st :: StateTree stateType w1 c1 e1 cs)) (Container _ _ oldChildren :: Children child e1
oldChildren) new :: Container container (Children child) e2
new@(Container (ManagedPtr container -> container
ctor :: Gtk.ManagedPtr
      w2
    -> w2) newAttributes :: Vector (Attribute container e2)
newAttributes (Children child e2
newChildren :: Children c2 e2))
    = case (StateTree stateType widget child event customState
st, (Typeable widget, Typeable container) =>
Maybe (widget :~: container)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @w1 @w2) of
      (StateTreeContainer top :: StateTreeNode widget event customState
top childStates :: Vector SomeState
childStates, 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 container e2
newCollected      = Vector (Attribute container e2) -> Collected container e2
forall widget event.
Vector (Attribute widget event) -> Collected widget event
collectAttributes Vector (Attribute container 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 container
newCollectedProps = Collected container e2 -> CollectedProperties container
forall widget event.
Collected widget event -> CollectedProperties widget
collectedProperties Collected container e2
newCollected
        in  if CollectedProperties widget
oldCollectedProps CollectedProperties widget -> CollectedProperties widget -> Bool
forall widget.
CollectedProperties widget -> CollectedProperties widget -> Bool
`canBeModifiedTo` CollectedProperties container
CollectedProperties widget
newCollectedProps
              then IO SomeState -> Patch
Modify (IO SomeState -> Patch) -> IO SomeState -> Patch
forall a b. (a -> b) -> a -> b
$ do
                container
containerWidget <- (ManagedPtr container -> container) -> widget -> IO container
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo ManagedPtr container -> container
ctor (StateTreeNode widget event customState -> widget
forall widget event customState.
StateTreeNode widget event customState -> widget
stateTreeWidget StateTreeNode widget event customState
top)
                container
-> CollectedProperties container
-> CollectedProperties container
-> IO ()
forall widget.
widget
-> CollectedProperties widget
-> CollectedProperties widget
-> IO ()
updateProperties container
containerWidget
                                 CollectedProperties container
CollectedProperties widget
oldCollectedProps
                                 CollectedProperties container
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 container e2 -> ClassSet
forall widget event. Collected widget event -> ClassSet
collectedClasses Collected container e2
newCollected)
                let top' :: StateTreeNode widget e2 customState
top' = StateTreeNode widget event customState
top { stateTreeCollectedAttributes :: Collected widget e2
stateTreeCollectedAttributes = Collected container e2
Collected widget e2
newCollected }
                StateTree 'ContainerState widget child 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 'ContainerState widget child e2 customState
 -> SomeState)
-> IO (StateTree 'ContainerState widget child e2 customState)
-> IO SomeState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateTree 'ContainerState widget child e2 customState
-> widget
-> Vector (child e1)
-> Vector (child e2)
-> IO (StateTree 'ContainerState widget child e2 customState)
forall container (child :: * -> *) event cs e1 e2.
(IsWidget container, IsContainer container, Patchable child,
 IsContainer container child) =>
StateTree 'ContainerState container child event cs
-> container
-> Vector (child e1)
-> Vector (child e2)
-> IO (StateTree 'ContainerState container child event cs)
patchInContainer
                  (StateTreeNode widget e2 customState
-> Vector SomeState
-> StateTree 'ContainerState widget child e2 customState
forall widget (child :: * -> *) event customState.
(IsContainer widget, IsContainer widget child) =>
StateTreeNode widget event customState
-> Vector SomeState
-> StateTree 'ContainerState widget child event customState
StateTreeContainer StateTreeNode widget e2 customState
top' Vector SomeState
childStates)
                  container
widget
containerWidget
                  (Children child e1 -> Vector (child e1)
forall (child :: * -> *) event.
Children child event -> Vector (child event)
unChildren Children child e1
oldChildren)
                  (Children child e2 -> Vector (child e2)
forall (child :: * -> *) event.
Children child event -> Vector (child event)
unChildren Children child e2
newChildren)
              else IO SomeState -> Patch
Replace (Container container (Children child) e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create Container container (Children child) e2
new)
      _ -> IO SomeState -> Patch
Replace (Container container (Children child) e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create Container container (Children child) e2
new)

--
-- EventSource
--

instance
  EventSource child =>
  EventSource (Container widget (Children child))
  where
  subscribe :: Container widget (Children child) event
-> SomeState -> (event -> IO ()) -> IO Subscription
subscribe (Container ctor :: ManagedPtr widget -> widget
ctor props :: Vector (Attribute widget event)
props children :: Children child event
children) (SomeState st :: StateTree stateType widget child event customState
st) cb :: event -> IO ()
cb = case StateTree stateType widget child event customState
st of
    StateTreeContainer top :: StateTreeNode widget event customState
top childStates :: Vector SomeState
childStates -> do
      widget
parentWidget <- (ManagedPtr widget -> widget) -> widget -> IO widget
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo ManagedPtr widget -> widget
ctor (StateTreeNode widget event customState -> widget
forall widget event customState.
StateTreeNode widget event customState -> widget
stateTreeWidget StateTreeNode widget event customState
top)
      Subscription
handlers' <- (Attribute widget event -> IO Subscription)
-> Vector (Attribute widget event) -> IO Subscription
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((event -> IO ())
-> widget -> Attribute widget event -> IO Subscription
forall widget (m :: * -> *) event.
(IsWidget widget, MonadIO m) =>
(event -> IO ())
-> widget -> Attribute widget event -> m Subscription
addSignalHandler event -> IO ()
cb widget
parentWidget) Vector (Attribute widget event)
props
      Subscription
subs <- (((child event, SomeState) -> IO Subscription)
 -> Vector (child event, SomeState) -> IO Subscription)
-> Vector (child event, SomeState)
-> ((child event, SomeState) -> IO Subscription)
-> IO Subscription
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((child event, SomeState) -> IO Subscription)
-> Vector (child event, SomeState) -> IO Subscription
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Vector (child event)
-> Vector SomeState -> Vector (child event, SomeState)
forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip (Children child event -> Vector (child event)
forall (child :: * -> *) event.
Children child event -> Vector (child event)
unChildren Children child event
children) Vector SomeState
childStates)
        (((child event, SomeState) -> IO Subscription) -> IO Subscription)
-> ((child event, SomeState) -> IO Subscription) -> IO Subscription
forall a b. (a -> b) -> a -> b
$ \(c :: child event
c, childState :: SomeState
childState) -> child event -> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe child event
c SomeState
childState event -> IO ()
cb
      Subscription -> IO Subscription
forall (m :: * -> *) a. Monad m => a -> m a
return (Subscription
handlers' Subscription -> Subscription -> Subscription
forall a. Semigroup a => a -> a -> a
<> Subscription
subs)
    _ ->
      [Char] -> IO Subscription
forall a. HasCallStack => [Char] -> a
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 :: Container widget children event -> Widget event
fromWidget = Container widget children event -> Widget event
forall (widget :: * -> *) event.
(Typeable widget, Patchable widget, Functor widget,
 EventSource widget) =>
widget event -> Widget event
Widget

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