{-# 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 f (MenuItem item         ) = MenuItem (fmap f item)
  fmap f (SubMenu label subMenu') = SubMenu label (fmap f 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 item attrs = MenuItem . Bin item 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 label = SubMenu label . container Gtk.Menu mempty

newSubMenuItem :: Text -> IO SomeState -> IO SomeState
newSubMenuItem label createSubMenu = do
  menuItem' <- Gtk.menuItemNewWithLabel label
  sc        <- Gtk.widgetGetStyleContext menuItem'
  SomeState (subMenuState :: StateTree st subMenu children e1 cs) <-
    createSubMenu
  case eqT @subMenu @Gtk.Menu of
    Just Refl -> do
      Gtk.menuItemSetSubmenu menuItem' (Just (stateTreeNodeWidget subMenuState))
      return
        (SomeState
          (StateTreeBin (StateTreeNode menuItem' sc mempty ())
                        (SomeState subMenuState)
          )
        )
    Nothing -> fail "Failed to create new sub menu item."

instance Patchable MenuItem where
  create = \case
    MenuItem item          -> create item
    SubMenu label subMenu' -> newSubMenuItem label (create subMenu')
  patch state (MenuItem (c1 :: Bin i1 e1)) (MenuItem (c2 :: Bin i2 e2)) =
    case eqT @i1 @i2 of
      Just Refl -> patch state c1 c2
      Nothing   -> Replace (create c2)
  patch (SomeState st) (SubMenu l1 c1) (SubMenu l2 c2) = case st of
    StateTreeBin top childState | l1 == l2 -> case patch childState c1 c2 of
      Modify  modify     -> Modify (SomeState . StateTreeBin top <$> modify)
      Replace newSubMenu -> Replace (newSubMenuItem l2 newSubMenu)
      Keep               -> Keep
    -- TODO: case for l1 /= l2
    _ -> Replace (create (SubMenu l2 c2))
  patch _ _ b2 = Replace (create b2)

instance EventSource MenuItem where
  subscribe (MenuItem item     ) state          cb = subscribe item state cb
  subscribe (SubMenu _ children) (SomeState st) cb = case st of
    StateTreeBin _ childState -> subscribe children childState cb
    _                         -> error
      "Warning: Cannot subscribe to SubMenu events with a non-bin state tree."

instance IsContainer Gtk.MenuShell MenuItem where
  appendChild shell _ widget' =
    Gtk.menuShellAppend shell =<< Gtk.unsafeCastTo Gtk.MenuItem widget'
  replaceChild shell _ i old new = do
    Gtk.containerRemove shell old
    menuItem' <- Gtk.unsafeCastTo Gtk.MenuItem new
    Gtk.menuShellInsert shell menuItem' i
    Gtk.widgetShowAll shell

instance IsContainer Gtk.MenuBar MenuItem where
  appendChild menuBar d w = do
    s <- Gtk.toMenuShell menuBar
    appendChild s d w
  replaceChild menuBar d i old new = do
    s <- Gtk.toMenuShell menuBar
    replaceChild s d i old new

instance IsContainer Gtk.Menu MenuItem where
  appendChild menuBar d w = do
    s <- Gtk.toMenuShell menuBar
    appendChild s d w
  replaceChild menuBar d i old new = do
    s <- Gtk.toMenuShell menuBar
    replaceChild s d i old new