Item.hs

{-# LANGUAGE TemplateHaskell #-}

module Model.Item (Item (..), populate) where

import Control.Monad (void)
import Data.Aeson.TH (deriveJSON)
import Data.Foldable (traverse_)
import Data.List (singleton)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import GHC.Generics (Generic)
import GI.Gtk qualified as Gtk
import Model.Checkbox (Checkbox (..))
import Model.Checkbox qualified as Checkbox
import Model.Internal (options)
import Model.Label (Label)
import Model.Label qualified as Label
import Model.RadioGroup (RadioGroup (..))
import Model.RadioGroup qualified as RadioGroup
import {-# SOURCE #-} Model.SubMenu (SubMenu)
import {-# SOURCE #-} Model.SubMenu qualified as SubMenu

data Item
  = MkItemLabel Label
  | MkItemCheckbox Checkbox
  | MkItemRadioGroup RadioGroup
  | MkItemSubMenu SubMenu
  | MkItemSeparator
  deriving stock (Eq, Generic, Show)

$(deriveJSON options ''Item)

populate :: Bool -> NonEmpty Item -> IO Gtk.Menu
populate verbose items = do
  menu <- Gtk.menuNew
  updateStateActions <- traverse (initAppendAndShow menu) items
  void $ Gtk.on menu #show $ sequence_ updateStateActions
  pure menu
  where
    initAppendAndShow :: Gtk.Menu -> Item -> IO (IO ())
    initAppendAndShow menu item = do
      (menuItems, updateAction) <- newItem verbose item
      traverse_ (appendAndShow menu) menuItems
      pure updateAction

    appendAndShow :: Gtk.Menu -> Gtk.MenuItem -> IO ()
    appendAndShow menu item = do
      Gtk.menuShellAppend menu item
      Gtk.widgetShow item

newItem :: Bool -> Item -> IO ([Gtk.MenuItem], IO ())
newItem verbose (MkItemLabel label) =
  (,mempty) . singleton <$> Label.newItem verbose label
newItem verbose (MkItemCheckbox checkbox) = do
  (item, updateAction) <- Checkbox.newItem verbose checkbox
  menuItems <- Gtk.toMenuItem item
  pure ([menuItems], updateAction)
newItem verbose (MkItemRadioGroup group) = do
  (items, updateAction) <- RadioGroup.newItems verbose group
  menuItems <- traverse Gtk.toMenuItem $ NE.toList items
  pure (menuItems, updateAction)
newItem verbose (MkItemSubMenu submenu) =
  (,mempty) . singleton <$> SubMenu.newItem verbose submenu
newItem _ MkItemSeparator =
  (,mempty) . singleton <$> (Gtk.toMenuItem =<< Gtk.separatorMenuItemNew)