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

module GI.Gtk.Declarative.Container.MenuItem
  ( MenuItem
  , menuItem
  , subMenu
  )
where

import           Data.Text                      ( Text )
import           Data.Typeable
import           Data.Vector                    ( Vector )
import qualified GI.Gtk                        as Gtk

import           GI.Gtk.Declarative.Attributes
import           GI.Gtk.Declarative.Bin
import           GI.Gtk.Declarative.Container
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

-- | A menu item widget used for 'Gtk.Menu' children.
data MenuItem event where
  -- | A single menu item in a 'Gtk.Menu'.
  MenuItem
    ::(Gtk.IsMenuItem item, Gtk.IsBin item, Typeable item)
    => Bin item event
    -> MenuItem event
  -- | A sub menu in a 'Gtk.Menu', with a text label and the list of
  -- child menu items.
  SubMenu
    ::Text -> Container Gtk.Menu (Children MenuItem) event -> MenuItem event

instance Functor MenuItem where
  fmap :: (a -> b) -> MenuItem a -> MenuItem b
fmap f :: a -> b
f (MenuItem item :: Bin item a
item         ) = Bin item b -> MenuItem b
forall item event.
(IsMenuItem item, IsBin item, Typeable item) =>
Bin item event -> MenuItem event
MenuItem ((a -> b) -> Bin item a -> Bin item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Bin item a
item)
  fmap f :: a -> b
f (SubMenu label :: Text
label subMenu' :: Container Menu (Children MenuItem) a
subMenu') = Text -> Container Menu (Children MenuItem) b -> MenuItem b
forall event.
Text -> Container Menu (Children MenuItem) event -> MenuItem event
SubMenu Text
label ((a -> b)
-> Container Menu (Children MenuItem) a
-> Container Menu (Children MenuItem) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Container Menu (Children MenuItem) a
subMenu')

instance ToChildren Gtk.Menu Vector MenuItem

instance ToChildren Gtk.MenuBar Vector MenuItem

-- | Construct a single menu item for a 'Gtk.Menu'.
menuItem
  :: ( Gtk.IsMenuItem item
     , Typeable item
     , Gtk.IsContainer item
     , Gtk.IsBin item
     , Gtk.IsWidget item
     )
  => (Gtk.ManagedPtr item -> item)
  -> Vector (Attribute item event)
  -> Widget event
  -> MenuItem event
menuItem :: (ManagedPtr item -> item)
-> Vector (Attribute item event) -> Widget event -> MenuItem event
menuItem item :: ManagedPtr item -> item
item attrs :: Vector (Attribute item event)
attrs = Bin item event -> MenuItem event
forall item event.
(IsMenuItem item, IsBin item, Typeable item) =>
Bin item event -> MenuItem event
MenuItem (Bin item event -> MenuItem event)
-> (Widget event -> Bin item event)
-> Widget event
-> MenuItem event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ManagedPtr item -> item)
-> Vector (Attribute item event) -> Widget event -> Bin item 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 item -> item
item Vector (Attribute item event)
attrs

-- | Construct a sub menu for a 'Gtk.Menu', wit a text label and the
-- child menu items.
subMenu :: Text -> Vector (MenuItem event) -> MenuItem event
subMenu :: Text -> Vector (MenuItem event) -> MenuItem event
subMenu label :: Text
label = Text -> Container Menu (Children MenuItem) event -> MenuItem event
forall event.
Text -> Container Menu (Children MenuItem) event -> MenuItem event
SubMenu Text
label (Container Menu (Children MenuItem) event -> MenuItem event)
-> (Vector (MenuItem event)
    -> Container Menu (Children MenuItem) event)
-> Vector (MenuItem event)
-> MenuItem event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ManagedPtr Menu -> Menu)
-> Vector (Attribute Menu event)
-> Vector (MenuItem event)
-> Container Menu (Children MenuItem) event
forall widget (child :: * -> *) (target :: * -> *)
       (parent :: * -> *) event.
(Typeable widget, Functor child, IsWidget widget,
 IsContainer widget,
 FromWidget (Container widget (Children child)) target,
 ToChildren widget parent child) =>
(ManagedPtr widget -> widget)
-> Vector (Attribute widget event)
-> parent (child event)
-> target event
container ManagedPtr Menu -> Menu
Gtk.Menu Vector (Attribute Menu event)
forall a. Monoid a => a
mempty

newSubMenuItem :: Text -> IO SomeState -> IO SomeState
newSubMenuItem :: Text -> IO SomeState -> IO SomeState
newSubMenuItem label :: Text
label createSubMenu :: IO SomeState
createSubMenu = do
  MenuItem
menuItem' <- Text -> IO MenuItem
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> m MenuItem
Gtk.menuItemNewWithLabel Text
label
  StyleContext
sc        <- MenuItem -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext MenuItem
menuItem'
  SomeState (StateTree stateType widget child event customState
subMenuState :: StateTree st subMenu children e1 cs) <-
    IO SomeState
createSubMenu
  case (Typeable widget, Typeable Menu) => Maybe (widget :~: Menu)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @subMenu @Gtk.Menu of
    Just Refl -> do
      MenuItem -> Maybe widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuItem a, IsMenu b) =>
a -> Maybe b -> m ()
Gtk.menuItemSetSubmenu MenuItem
menuItem' (widget -> Maybe widget
forall a. a -> Maybe a
Just (StateTree stateType widget child event customState -> widget
forall (stateType :: StateType) widget (child :: * -> *) event
       customState.
StateTree stateType widget child event customState -> widget
stateTreeNodeWidget StateTree stateType widget child event customState
subMenuState))
      SomeState -> IO SomeState
forall (m :: * -> *) a. Monad m => a -> m a
return
        (StateTree 'BinState MenuItem Any Any () -> SomeState
forall widget customState (stateType :: StateType)
       (child :: * -> *) event.
(IsWidget widget, Typeable widget, Typeable customState) =>
StateTree stateType widget child event customState -> SomeState
SomeState
          (StateTreeNode MenuItem Any ()
-> SomeState -> StateTree 'BinState MenuItem Any Any ()
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> SomeState -> StateTree 'BinState widget child event customState
StateTreeBin (MenuItem
-> StyleContext
-> Collected MenuItem Any
-> ()
-> StateTreeNode MenuItem Any ()
forall widget event customState.
widget
-> StyleContext
-> Collected widget event
-> customState
-> StateTreeNode widget event customState
StateTreeNode MenuItem
menuItem' StyleContext
sc Collected MenuItem Any
forall a. Monoid a => a
mempty ())
                        (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
subMenuState)
          )
        )
    Nothing -> String -> IO SomeState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Failed to create new sub menu item."

instance Patchable MenuItem where
  create :: MenuItem e -> IO SomeState
create = \case
    MenuItem item :: Bin item e
item          -> Bin item e -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create Bin item e
item
    SubMenu label :: Text
label subMenu' :: Container Menu (Children MenuItem) e
subMenu' -> Text -> IO SomeState -> IO SomeState
newSubMenuItem Text
label (Container Menu (Children MenuItem) e -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create Container Menu (Children MenuItem) e
subMenu')
  patch :: SomeState -> MenuItem e1 -> MenuItem e2 -> Patch
patch state :: SomeState
state (MenuItem (Bin item e1
c1 :: Bin i1 e1)) (MenuItem (Bin item e2
c2 :: Bin i2 e2)) =
    case (Typeable item, Typeable item) => Maybe (item :~: item)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @i1 @i2 of
      Just Refl -> SomeState -> Bin item e1 -> Bin item e2 -> Patch
forall (widget :: * -> *) e1 e2.
Patchable widget =>
SomeState -> widget e1 -> widget e2 -> Patch
patch SomeState
state Bin item e1
c1 Bin item e2
Bin item e2
c2
      Nothing   -> IO SomeState -> Patch
Replace (Bin item e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create Bin item e2
c2)
  patch (SomeState st :: StateTree stateType widget child event customState
st) (SubMenu l1 :: Text
l1 c1 :: Container Menu (Children MenuItem) e1
c1) (SubMenu l2 :: Text
l2 c2 :: Container Menu (Children MenuItem) e2
c2) = case StateTree stateType widget child event customState
st of
    StateTreeBin top :: StateTreeNode widget event customState
top childState :: SomeState
childState | Text
l1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
l2 -> case SomeState
-> Container Menu (Children MenuItem) e1
-> Container Menu (Children MenuItem) e2
-> Patch
forall (widget :: * -> *) e1 e2.
Patchable widget =>
SomeState -> widget e1 -> widget e2 -> Patch
patch SomeState
childState Container Menu (Children MenuItem) e1
c1 Container Menu (Children MenuItem) e2
c2 of
      Modify  modify :: IO SomeState
modify     -> IO SomeState -> Patch
Modify (StateTree 'BinState widget Any 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 'BinState widget Any event customState -> SomeState)
-> (SomeState -> StateTree 'BinState widget Any event customState)
-> SomeState
-> SomeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateTreeNode widget event customState
-> SomeState -> StateTree 'BinState widget Any event customState
forall widget event customState (child :: * -> *).
StateTreeNode widget event customState
-> SomeState -> StateTree 'BinState widget child event customState
StateTreeBin StateTreeNode widget event customState
top (SomeState -> SomeState) -> IO SomeState -> IO SomeState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SomeState
modify)
      Replace newSubMenu :: IO SomeState
newSubMenu -> IO SomeState -> Patch
Replace (Text -> IO SomeState -> IO SomeState
newSubMenuItem Text
l2 IO SomeState
newSubMenu)
      Keep               -> Patch
Keep
    -- TODO: case for l1 /= l2
    _ -> IO SomeState -> Patch
Replace (MenuItem e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create (Text -> Container Menu (Children MenuItem) e2 -> MenuItem e2
forall event.
Text -> Container Menu (Children MenuItem) event -> MenuItem event
SubMenu Text
l2 Container Menu (Children MenuItem) e2
c2))
  patch _ _ b2 :: MenuItem e2
b2 = IO SomeState -> Patch
Replace (MenuItem e2 -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create MenuItem e2
b2)

instance EventSource MenuItem where
  subscribe :: MenuItem event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe (MenuItem item :: Bin item event
item     ) state :: SomeState
state          cb :: event -> IO ()
cb = Bin item event -> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe Bin item event
item SomeState
state event -> IO ()
cb
  subscribe (SubMenu _ children :: Container Menu (Children MenuItem) event
children) (SomeState st :: StateTree stateType widget child event customState
st) cb :: event -> IO ()
cb = case StateTree stateType widget child event customState
st of
    StateTreeBin _ childState :: SomeState
childState -> Container Menu (Children MenuItem) event
-> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe Container Menu (Children MenuItem) event
children SomeState
childState event -> IO ()
cb
    _                         -> String -> IO Subscription
forall a. HasCallStack => String -> a
error
      "Warning: Cannot subscribe to SubMenu events with a non-bin state tree."

instance IsContainer Gtk.MenuShell MenuItem where
  appendChild :: MenuShell -> MenuItem event -> Widget -> IO ()
appendChild shell :: MenuShell
shell _ widget' :: Widget
widget' =
    MenuShell -> MenuItem -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuShell a, IsMenuItem b) =>
a -> b -> m ()
Gtk.menuShellAppend MenuShell
shell (MenuItem -> IO ()) -> IO MenuItem -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ManagedPtr MenuItem -> MenuItem) -> Widget -> IO MenuItem
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo ManagedPtr MenuItem -> MenuItem
Gtk.MenuItem Widget
widget'
  replaceChild :: MenuShell -> MenuItem event -> Int32 -> Widget -> Widget -> IO ()
replaceChild shell :: MenuShell
shell _ i :: Int32
i old :: Widget
old new :: Widget
new = do
    MenuShell -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerRemove MenuShell
shell Widget
old
    MenuItem
menuItem' <- (ManagedPtr MenuItem -> MenuItem) -> Widget -> IO MenuItem
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
Gtk.unsafeCastTo ManagedPtr MenuItem -> MenuItem
Gtk.MenuItem Widget
new
    MenuShell -> MenuItem -> Int32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuShell a, IsWidget b) =>
a -> b -> Int32 -> m ()
Gtk.menuShellInsert MenuShell
shell MenuItem
menuItem' Int32
i
    MenuShell -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll MenuShell
shell

instance IsContainer Gtk.MenuBar MenuItem where
  appendChild :: MenuBar -> MenuItem event -> Widget -> IO ()
appendChild menuBar :: MenuBar
menuBar d :: MenuItem event
d w :: Widget
w = do
    MenuShell
s <- MenuBar -> IO MenuShell
forall (m :: * -> *) o.
(MonadIO m, IsMenuShell o) =>
o -> m MenuShell
Gtk.toMenuShell MenuBar
menuBar
    MenuShell -> MenuItem event -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Widget -> IO ()
appendChild MenuShell
s MenuItem event
d Widget
w
  replaceChild :: MenuBar -> MenuItem event -> Int32 -> Widget -> Widget -> IO ()
replaceChild menuBar :: MenuBar
menuBar d :: MenuItem event
d i :: Int32
i old :: Widget
old new :: Widget
new = do
    MenuShell
s <- MenuBar -> IO MenuShell
forall (m :: * -> *) o.
(MonadIO m, IsMenuShell o) =>
o -> m MenuShell
Gtk.toMenuShell MenuBar
menuBar
    MenuShell -> MenuItem event -> Int32 -> Widget -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Int32 -> Widget -> Widget -> IO ()
replaceChild MenuShell
s MenuItem event
d Int32
i Widget
old Widget
new

instance IsContainer Gtk.Menu MenuItem where
  appendChild :: Menu -> MenuItem event -> Widget -> IO ()
appendChild menuBar :: Menu
menuBar d :: MenuItem event
d w :: Widget
w = do
    MenuShell
s <- Menu -> IO MenuShell
forall (m :: * -> *) o.
(MonadIO m, IsMenuShell o) =>
o -> m MenuShell
Gtk.toMenuShell Menu
menuBar
    MenuShell -> MenuItem event -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Widget -> IO ()
appendChild MenuShell
s MenuItem event
d Widget
w
  replaceChild :: Menu -> MenuItem event -> Int32 -> Widget -> Widget -> IO ()
replaceChild menuBar :: Menu
menuBar d :: MenuItem event
d i :: Int32
i old :: Widget
old new :: Widget
new = do
    MenuShell
s <- Menu -> IO MenuShell
forall (m :: * -> *) o.
(MonadIO m, IsMenuShell o) =>
o -> m MenuShell
Gtk.toMenuShell Menu
menuBar
    MenuShell -> MenuItem event -> Int32 -> Widget -> Widget -> IO ()
forall container (child :: * -> *) event.
IsContainer container child =>
container -> child event -> Int32 -> Widget -> Widget -> IO ()
replaceChild MenuShell
s MenuItem event
d Int32
i Widget
old Widget
new